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Objectives 


The  purpose  of  this  project  was  to  introduce  the  language  Ada  into  our  compiler 
design  curriculum  as  the  development  language.  To  this  end  our  course  which  had  been 
traditionally  taught  using  Pascal  was  to  be  reworked  so  that  the  programming  portion  would 
now  be  done  in  Ada.  In  addition,  while  a  subset  of  Pascal  had  been  normally  used  as  the 
target  design  compiler,  the  course  was  now  to  have  a  language  similar  to  a  subset  of  Ada  as 
the  target  design  compiler.  This  in  fact  was  carried  out  and  the  ensuing  report  describes  some 
aspects  of  the  course  development. 
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Initial  Considerations 


Ada  had  never  been  used  as  a  programming  language  at  Lehigh.  Thus  it  was 
necessary  to  introduce  Ada  during  the  course.  Fortunately  the  students  in  the  class  were  all 
accomplished  programmers  familiar  with  Pascal.  Thus  it  was  possible  to  initially  restrict  the 
use  of  Ada  to  portions  which  most  resembled  Pascal  and  then  introduce  more  concepts  as  we 
progressed.  A  more  daunting  task  for  the  writer  was  to  develop  a  syntax  for  the  language 
which  was  to  be  the  ultimate  language  to  be  compiled.  The  writer  believes  that  LL(1)  syntaxes 
are  the  most  amenable  to  compiler  development.  Since  no  really  good  automated  tool  is 
available  an  LL(1)  form  of  a  subset  of  Ada  which  includes  packages  had  to  be  developed.  The 
LRM  for  Ada  was  not  too  useful  in  this  regard.  However  by  using  some  portions  of  Pascal  and 
some  additions  a  suitable  syntax  was  developed.  This  syntax  gave  a  language  which  strongly 
resembles  a  small  but  useful  subset  of  Ada  with  some  restrictions.  Examples  can  be  seen  later 
in  the  technical  portion  of  the  report.  Once  this  had  been  done  the  text.  Crafting  a  Compiler 
by  Fischer  and  LeBlanc,  which  is  also  written  in  Ada,  enabled  the  writer  with  the  addition  of 
some  other  materials  to  produce  and  carry  out  the  course  in  the  Fall  of  1992  as  CSC  397 
Compiler  Design  using  Ada.  The  writer,  having  become  somewhat  enthusiastic  about  the  use 
of  Ada,  is  again  teaching  the  Compiler  Design  course,  this  semster  (spring  1993)  using  Ada.  It 
might  be  added  that  there  were  start-up  difficulties  in  that  the  Ada  compilers  were  not  at  first 
easily  available  to  the  students. 

The  compiler  which  we  first  proposed  to  use  was  the  Meridian  open  Ada  compiler.  This 
worked  well  on  individual  286,  386  and  486  PC’s.  However,  at  Lehigh,  the  facilities  provided  to 
the  students  are  only  through  networking.  That  is  all  of  the  PC’s  are  networked  through 
LAN’s  to  file  servers  using  Novell  software.  Unfortunately,  license  agreements  would  not 
permit  us  to  give  the  students  individual  copies  of  the  compilers  and  the  software  in  our  LAN's 
had  an  unfortunate  interaction  with  the  Meridian  compilers.  The  interaction  was  of  such  a 
nature  that  it  made  the  compilers  very  difficult  to  use  and  the  cause  of  the  interaction  was  not 
well  understood.  Fortunately,  Lehigh  had  also  made  a  purchase  of  IBM  Risc/6000  work 
stations  and  with  those  came  an  AIX  Ada  compiler.  Once  again  this  compiler  would  not  work 
on  the  LAN’s  connecting  those  systems  however  it  did  work  on  a  central  machine  that  had 
been  set  up  as  a  mainframe.  Though  this  machine  provided  something  of  a  bottleneck  and  t.hp 
compiler  v. <xs  aliil  inconvenient  it  was  possible  for  the  students  to  do  their  work.  Later  we  were 
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able  to  make  the  Meridian  compilers  more  usuable  but  they  were  still  inconvenient.  The 
computing  center  now  promises  to  fix  the  problem  on  our  PC  LAN’s.  However  presently  the 
Meridian  compliers  are  now  more  easily  available  on  our  LAN’s  by  using  other  systems  not 
originally  developed  by  Meridian. 
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Comments  on  Course  Materials 
and  Syllabus 


For  the  most  part  the  text  [F  -  L]  listed  below  was  used  as  reading  material  for  the 
students.  However  some  parts  of  the  text,  in  particular  material  on  the  theory  of  syntax  was 
not  quite  to  the  writers  liking.  Since  the  formulation  of  the  syntax  for  the  target  language  had 
occupied  more  of  the  writer’s  time  than  anticipated  there  was  less  time  to  produce  note 
materials  to  fill  what  were  considered  to  be  gaps  in  description.  However,  another  text,  [T  - 

S],  was  used  as  a  supplement  for  the  required  materials.  In  addition,  in  the  development  of  the 
compiler,  the  writer  provided  students  with  partially  completed  portions  and  had  the  students, 
in  teams,  complete  them.  The  syllabus  of  the  course  was  substantially  as  provided  in  the 
project  proposal  namely: 

1)  Language  constructs  and  practical  implementation  of  an  LL(1)  parser. 

2)  Data  structures  including  arrays  and  records. 

3)  Control  structures;  however,  the  case  statement  was  omitted. 

4)  Program  structures  including  procedures  and  a  simplified  version  of  packages. 

5)  Code  generation  into  the  code  of  an  interpretive  machine  akin  to  the  Pascal  p- 
machine  which  we  call  an  a-machine. 

6)  A  concrete  a-machine  written  in  Ada. 

7)  An  LL(1)  syntax  for  our  language. 

8)  A  4-pass  compiler  for  our  language 

9)  Some  discussion  of  attribute  methods  in  relation  to  our  compiler. 

Much  of  the  material  was  supported  by  the  references  below  and  lectures  by  the  writer. 
The  material  from  [F  -  L]  was  used  as  follows: 

Chap.  2  A  brief  overview  is  given.  A  good  part  of  the  general  structure  of  a  compiler  is  in 
this  chapter. 

Chap.  3  The  scanning  touches  on  the  general  notion  of  FSA.  The  students  have  had  this  in 
another  course.  Passl  was  discussed  with  care. 

Chap.  5  This  chapter  deals  with  syntax  and  parsing.  The  material  from  [T  -  S]  was 
preferred.  See  below. 

Chap.  7  Semantic  processing.  This  chapter  is  somewhat  cursory.  Parts  of  pass2  were  used  as 
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a  text.  The  po-tions  shown  to  the  students  will  depend  on  the  instructor  and  the 
course. 

Chap.  8  Symbol  tables.  This  was  supplemented  by  [T  -  S]  see  below. 

Chap.  9  Run-time  storage  organization.  VVe  preferred  [T  -  S]  for  this. 

Chapters  used  in  [T  -  S] 

Chap.  2,  6  Give  a  good  account  of  syntax  and  top  down  parsing. 

Chap.  9  This  is  a  nice  account  of  run  time  storage  organization. 

Chap.  11  This  was  used  for  semantic  analysis  and  code  generation.  Parts  of  pass3  were  also 
used. 

Chapters  2,  6  and  9  where  used  in  [T  -  Sj.  [H]  and  [VV]  provided  general  inspiration. 

[H]  is  a  very  practical  account  of  compiling.  Unfortunately  the  book  is  out  of  print.  However 
some  of  the  lectures  were  based  on  the  ideas  given  there. 

References 

[F  -  L]  Fischer,  Charles  N.  and  R.  J.  LeBlanc,  Jr.  Crafting  a  Compiler,  The 
Benjamin/Cummings  Publishing  Co.,  Menlo  Park,  CA,  1988 

[T  -  S]  J-T.  Tremblay  and  P.  G.  Sorensen,  The  Theory  and  Practice  of  Compiler  Writing, 
McGraw-Hill  Book  Co.  New  York,  NY,  1985. 

[H]  P.  B.  Hansen,  Programming  a  Personal  Computer,  Prentice-Hall,  Inc.,  Englewood  Cliffs, 
NJ  1982 

[W]  The  Pacals  Compiler  developed  by  N.  Wirth. 
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The  Compiler: 

General  Considerations 

1.  Syntax 

Here  we  present  the  syntax  of  the  language  to  be  compiled.  The  syntax  is  LL(1) 
and  the  language  has  strong  similarities  to  Ada.  Some  differences  were  introduced  to  make 
sure  the  user  notes  the  distinction.  We  use  ‘proc’,  ‘int’,  ‘bool’,  ‘pack’  for  ‘procedure1,  ‘integer’, 
‘boolean’  and  ‘package’  respectively.  We  do  not  provide  the  facility  for  the  procedure  name  to 
be  used  at  the  end  of  the  procedure  and  we  end  our  packs  with  end  pack.  Here  is  an  example, 
a  bubble  sort  written  in  a  somewhat  complicated  way,  to  demonstrate  some  of  the  features  of 
our  language.  This  example  will  appear  again  later. 

proc  tst24  is 

type  table  is  array(0  ..  25)  of  int; 
type  1st  is  record 
fin:  int; 
list:  table; 
end  record; 

i:  int; 
list:  1st; 

pack  sort  is 

proc  init(il:  out  1st;  n:  int); 
proc  print(U:  cut  1st;  n:  int); 
proc  bubsrt(U:  out  1st); 
end  pack; 

pack  body  sort  is 

proc  init(U:  out  1st;  n:  int)  is 
i:  int; 
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begin 

11. fin  —  n; 

while  i  <=  n  loop 
ll.list(i)  :=  n  +  1  -  i; 
i  :=  i  +  1; 
end  loop; 
end; 

proc  p r i n t ( 1 1 :  out  1st;  n:  int)  is 
i:  int; 
begin 
i  :=  1; 

while  i  <=  n  loop 
write(Il.list(i):4); 

i  :=  i  +  1; 

end  loop; 
end; 

proc  bubsrt(ll:  out  1st)  is 
temp,  i,  j:  int; 
begin 
i  :=  2; 

while  i  <—  ll.fin  loop 
ll.list(O)  :=  ll.list(i); 

j  :=  i; 

while  U.list(j)  <  li.list(j-l)  loop 
temp  :=  ll.list(j); 
ll.list(j)  :=  U.list (j  -  1); 

11  -list (j  -  1)  :=  temp; 

J  :=  j  -  1; 

end  loop; 

i  :=  i  +  I; 

end  loop; 
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end; 

end  pack; 


begin 

sort.init(llst,  8); 
sort.bubsrt(llst); 
sort.print(llst,  8); 
end; 


The  reader  will  note  that  this  program  has  an  appearance  which  is  substantially 
like  that  of  Ada.  The  syntax  of  our  language  Mic  follows.  Note  that  A  is  the  null  string  and 
that  the  syntax  has  not  been  ‘massaged’  iiitr  EBNF  form.  The  syntax  was  created  to  be  very 
modular.  The  recursion  created  by  the  syntax  does  not  place  a  very  large  overhead  on 
execution  during  parsing.  These  days  with  PC’s  having  memories  with  a  minini',’'n  of  640k 
and  relatively  fast  execution  the  use  of  syntax  in  pure  BNF  form  provides  no  problem.  It  has 
the  additional  advantage  that  the  structure  of  the  parser  can  be  made  to  reflect  the  syntax 
well.  This  makes  program  development  and  debugging  relatively  simple. 

terminals 

colon,  semicolon,  type_id,  type,  airay,  is,  int,  bool,  char, 

Iparen,  rparen,  of,  int _ lit,  dotdot,  end,  record,  id, 

comma,  eq,  ne,  It,  Ie,  gt,  ge,  plus,  minus,  and,  star,  slash, 
mod,  div,  or,  not,  null,  rec_id,  proc_id,  if,  then,  elsif,  else, 
exit,  when,  loop,  while  ,  procedure  ,  in,  out,  gr_char,  begin, 
dot,  becomes,  pkg_id,  pkg_idl, 
pack,  body,  true,  false,  write,  writeln,  read  ; 

nonterminals 

<declaration>,  <object_decl>,  <type_decl>,  <subprog_decl>, 

<package_decl>,  <id_list>, 

< id _ list _ tail > ,  <type_inf>,  <type_def>,  <stype_def>, 

<array_def>,  <index_bd>,  <record _def> ,  <index_range>,  <comp_def>, 
<comp_def_tail>,  <subprog_heauer>  , 

<formal_part>  ,  <subprog_part>  ,  <param__dec!>  ,  <sparam_decl>,  < p _ tail >  , 
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<mode>  ,  <p_dec_tail>  ,  <decl_part>  ,  <pkg_tail>,  <pkg_  def_deci>, 
<pkg_d_decl>,  <pkg_body_decl>,  <pkg_b_decl>, 

<re!ational_op>,  <unary_add_op>,  <binary_add_op>,  <term>,  <rr>ul_op>, 
<simp_expr>,  <sexp_tail>,  <factor>,  < term _ tail >, 

<vbll>,  <vbi_tail>,  <vl_tail>,  <vb!2>,  <vbl>,  <expression>, 

<exp_tai!>,  <statement>,  <lstatement>, 

<stat_seq>.  <lstat_seq>,  <stat_seq_tail>,  <lstat_seq_tail>, 

<simp_stat>,  <write_stat>,  <write_body>,  <w_tail>, 

<read_stat>,  <comp_stat>,  <proc_call_stat>,  <pk_stat>,  <pk_stat_tail>, 
<assign_stat>,  <exit_stat>  ,  <exp_p_sub>, 

<p_call _ tail > ,  <p_sub_tail>  ,  <if_stat>,  <loop_stat>,  <while_stat>, 

<elsif_part>  ,  <else_part>  ,  <program>; 
start  symbol 
<program>  ; 

productions 

<declaration>  —  >  <object_decl> 

<declaration>  — >  <type_decl> 

<declaration>  — >  <subprog_decl> 

<declaration>  --->  <package_decl> 

<object_decl>  --->  < id _ list>  colon  type_id  semicolon 

<id _ list>  — ->  id  <id _ list _ ta.il> 

<id _ list _ ta.il>  — >  comma  id  <id _ list _ tail> 

<id _ list _ tail>  — >  A 

<type_ind>  — >  type_id 
<type_ind>  — >  <stype_def> 

<type_decl>  — >  type  type_id  is  <type_def>  semicolon 
<type_def>  — >  <stype_def> 

<stype_def>  —  >  int 
<stype_dc.>  — >  bool 
<stype_def>  —  >  char 
<type_def>  —  >  <array_def> 

<type_def>  —  ->  <record_def> 
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<array_def>  --->  array  I- aren  <index_range>  rparen  of  type_id 
<index_range>  —  >  <index_bd>  dotdot  <index_bd> 

<index_bd>  — >  int _ lit 

<index_bd>  — ->  plus  int _ lit 

<index_bd>  — >  minus  int _ lit 

<record_def>  —  >  record  <comp_def>  end  record 
<comp_def>  — ->  <object_decl>  <comp_def_tail> 
<comp_def_tail>  — ->  <object_decl>  <comp_def_tail> 
<comp_def_tail>  — >  A 

<subprog_decl>  --->  <subprog_header>  is  <subprog_part> 
semicolon 

<subprog_header>  — >  procedure  id  <formal_part> 
<formal_part>  — >  lparen  <param_decl>  rparen 
<formal_part>  — >  A 

<sparam_decl>  — >  id  <p_tail>  colon  <mode>  <type_def> 

<p _ tail>  — >  comma  id  <p_tail> 

<p_tail>  — >  A 
<moae>  —  >  in 
<mode>  --->  out 
<mode>  — >  A 

<param_decl>  —  >  <sparam_decl>  <p_dec_tail> 

<p_dec_tail>  — >  semicolon  <sparam_decl>  <p_dec_tail> 
<p_dec_tail>  — >  A 

<subprog_part>  — >  <decl_part>  begin  <stat_seq>  end 
<decl_part>  —  >  <declaration>  <decl_part> 

<decl_part>  — >  A 
<package_decl>  —  >  pack  <pkg_tail> 

<pkg_ta.il>  — >  pkg_id  is  <pkg_def_decl> 

<pkg_tail>  — >  body  pkg_id  is  <pkg_uody_decl> 
<pkg_def_decl>  — >  <pkg_d_dec!>  end  pack  semicolon 
<pkg_d_decl>  --->  <object_decl>  <pkg_d_decl> 
<pkg_d_decl>  — >  <type_deci>  <pkg_d_decl> 

<pkg_d_decl>  — >  <subprog_header>  semicolon  <pkg_d_decl> 
<pkg_d_decl>  --->  A 
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<pkg_b°dy_de<:l>  — >  <pkg_b_decl>  end  pack  semicolon 

<pkg_b_deci>  —  >  <object_decl>  <pkg_b_dec!> 

<pkg_b_decl>  — >  <type_decl>  <pkg_b__decl> 

<pkg_b_decl>  — >  <subprog_decl>  <pkg_b_decl> 

<pkg_b_decl>  — >  A 

<relational_op'>  — >  eq 

<relational_op>  — >  ne 

<relational_op>  — >  It 

<relational_op>  — >  le 

<relational_op>  — >  gt 

<relational_op>  —  >  ge 

<unary_add_op>  — >  plus 

<unary_add_op>  — >  minus 

<unary_add_op>  —  >  A 

<binary_add_op>  — >  plus 

<binary_add_op>  —  >  minus 

< binary _add__op>  -- >  or 

<mul_op>  — >  star 

<mul_op>  — >  div 

<mul_op>  —  >  mod 

<mul_op>  — >  and 

<term>  — >  <factor>  <term_tail> 

<term_tail>  — >  <mul_op>  <factor>  <term_tail> 
<term_tail>  — >  A 
<factor>  — >  int _ lit 

<factor>  — >  Iparen  <expression>  rparen 
<factor>  — >  <vbl> 

<factor>  — >  not  <factor> 

<factor>  —  >  true 
<factor>  —  >  false 
<vbll>  — >  rec_id  <vl_tail> 

<vbll>  —  >  id  <vbl_tail>  <vl_tail> 

<vl_tail>  — >  dot  <vbll> 

<vl  ta.il>  —  >  A 
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<vbl _ tail>  --->  Iparen  <expression>  rparen  <vbl_tail> 

<vbl_tail>  — >  A 

<vbl2>  —  >  pkg_id  dot  <vbll> 

<vbl>  —  >  <vbll> 

<vbl>  -->  <vb!2> 

<simp_expr>  — >  <unary _add_op>  <term>  <sexp_tail> 
<sexp_tail>  — ->  <binary_add_op>  <term>  <sexp_tail> 
<sexp_tail>  —  >  A 

<expression>  —  ->  <simp_expr>  <exp_tail> 

<exp_tail>  — >  <relational_op>  <simp_expr> 

<exp_tail>  — >  A 
<lstatement>  — >  <statement> 

<lstatement>  — >  <exit_stat>  semicolon 
<exit_stat>  — >  exit  when  <expression> 

<lstat_seq>  — >  <lstatement>  <lstat_seq_tail> 
<lstat_seq_tail>  — >  <lstatement>  <lstat_seq_tail> 
<lstat_seq_tail>  —  >  A 
<statement>  — >  <sirnp_stat>  semicolon 
<statement>  — >  <comp_stat>  semicolon 
<stat_seq>  — >  <statement>  <stat_seq_tail> 
<stat_seq_tail>  — >  <statement>  <stat_seq_tail> 
<stat_seq_tail>  — >  A 
<simp_stat>  — >  null 
<simp_stat>  — >  <pk_stat> 

<pk_stat>  — >  pkg_id  dot  <pk_stat_tail> 
<pk_stat_tail>  — >  <proc_call_st,at> 

<pk_stat_tail>  —  >  <assign_stat> 

<simp_stat>  — >  <proc_call_stat> 

<simp_stat>  — >  <assign_stat> 

<simp_stat>  —  >  <write_stat> 

<simp_stat>  —  >  <read_stat> 

<write_stat>  —  >  write  <write_body> 

<write_stat>  — >  writeln 

<write_body>  — >  Iparen  <expression>  <w_tail>  rparen 
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<w_tail>  — >  colon  <expression> 

<w_tail>  —  >  A 

<read__stat>  — >  read  iparen  id  rparen 
<proc_call_stat>  -  ->  proc_id  <p_call_tai)> 

<exp_p_sub>  —  >  <expression>  <p_sub_tail> 

<p_call_tail>  -— >  Iparen  <exp_p_sub>  rparen 
<p_call_tail>  — >  A 

<p_sub_tail>  —  ->  comma  <exp_p_sub> 

<p_sub_tail>  — >  A 

<assign_stat>  —  >  <vbll>  becomes  <expression> 

<comp_stat>  —  >  <if_stat> 

<comp_stat>  — >  <ioop_stat> 

<comp_stat>  — >  <while_stat> 

<if_stat>  — >  if  <expression>  then  <stat_seq>  <eisif_part>  <else_part> 
end  if 

<elsif_part>  — >  elsif  <expression>  then  <stat_seq> 

<elsif_part>  —  >  A 
<else_part>  — >  else  <stat_seq> 

<else_part>  — >  A 

<loop^stat>  —  >  loop  <lstat_seq>  end  loop 
<while_stat>  — >  while  <expression>  <loop_stat> 

<program>  — >  <subprog_decl> 

In  order  to  be  able  to  use  the  syntax  to  write  a  parser  we  need  an  anlaysis  of  the  syntax 
into  first  symbols  and  follow  symbols.  This  is  provided  by  a  system  written  some  time  ago  by 
the  writer.  The  report  of  this  system  is  as  follows: 


NULLABLE  NONTERMINALS 

<id _ list _ ta.il>  <comp_def_tail>  <formal_part>  <p_tail>  <mode>  <p_dec_tail> 

<decl__part>  <pkg_d_decl>  <pkg_b_decl>  <unary_add_op>  <sexp_tail> 
<term__tail>  <vbl_tail>  <vl_tail>  <exp_tail>  <stat_seq_tail>  <lstat_seq_tail> 
<w_tail>  <p_call_tail>  <p_sub_tail>  <elsif_part>  <else_part> 
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FIRST  SETS 

<declaration> 

type  id  procedure  pack 

<object_decl> 

id 

<type_decl> 

type 

<subprog_decl> 

procedure 

<package_decl> 

pack 

<id _ list  > 

id 

<id _ list _ tail> 

A  comma 

<type_ind> 

type_id  int  bool  char 

<type_def> 

array  int  bool  char  record 

<stype_def> 

int  bool  char 

<array_def> 

array 

<index_bd> 

int _ lit  plus  minus 

<record__def> 

record 

<index_range> 

int _ lit  plus  minus 

<comp_def> 

id 

<comp_def_tail> 

A  id 

<subprog_header> 

procedure 

<formal_part> 

A  lparen 

<subprog_  part> 

type  id  procedure  begin  pack 

<param_decl> 

id 

<sparam_decl> 

id 

<p_tail> 

A  comma 

<mode> 

A  in  out 

<p_dec_tail> 

A  semicolon 

<decl_part> 

A  type  id  procedure  pack 

<pkg_tail> 

pkg_id  body 

<pkg_def_decl> 

type  end  id  procedure 

<pkg_d_decl> 

A  type  id  procedure 

<pkg_b°dy_decl> 

type  end  id  procedure 

<pkg_b_decl> 

A  type  id  procedure 

<relational_op> 

eq  ne  It  le  gt  ge 
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<unary_add_op> 

A  plus  minus 

<binary_add_op> 

plus  minus  or 

<term> 

lparen  int _ lit  id  not  rec_id  pkg_id  true  false 

<mul_op> 

and  star  mod  div 

<simp_expr> 

A  lparen  int _ lit  id  plus  minus  not  rec_id  pkg_id 

true  false 

<sexp_tail> 

A  plus  minus  or 

<factor> 

lparen  int _ lit  id  not  rec_id  pkg_id  true  false 

<term_tail> 

A  and  star  mod  div 

<vbll> 

id  rec_id 

<vbl_tail> 

A  lparen 

<vl_tail> 

A  dot 

<vbl2> 

pkg_id 

<vbl> 

id  rec__id  pkg_id 

<expression> 

A  lparen  int _ lit  id  plus  minus  not  rec_id  pkg_id 

true  false 

<exp_tail> 

A  eq  ne  It  le  gt  ge 

<statement> 

id  null  rec_id  proc_id  if  loop  while  pkg_id 

write  writeln  read 

<lstatement> 

id  null  rec_id  proc  id  if  exit  loop  while  pkg_id 

write  writeln  read 

<stat_seq> 

id  null  rec_id  proc_id  if  loop  while  pkg_id 

write  writeln  read 

<lstat_seq> 

id  null  rec_id  proc_id  if  exit  loop  while  pkg_id 

write  writeln  read 

<stat_seq_tail> 

A  id  null  rec_id  proc_id  if  loop  while  pkg_id 

write  writeln  read 

<lstat_seq_tail> 

A  id  null  rec_id  proc_id  if  exit  loop  while 

pkg_id  write  writeln  read 

<simp_stat> 

id  null  rec_id  proc_id  pkg_id  write  writeln 

read 

<write_stat> 

write  writeln 

<write_body> 

lparen 

<w__tail> 

A  colon 
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<read_stat> 

read 

<comp_stat> 

if  loop  while 

<proc_call_stat> 

proc_id 

<pk_stat> 

pkg_id 

<pk_stat_tail> 

id  rec_id  proc  id 

<assign_stat> 

id  rec_id 

<exit_stat> 

exit 

<exp_p_sub> 

A  Iparen  int _ lit  id  plus  minus  not  r 

true  false 

<p_cail_tail> 

A  Iparen 

<p_sub_tail> 

A  comma 

<if_stat> 

if 

<loop_stat> 

loop 

<while  stat> 

while 

<elsif_part> 

A  elsif 

<else_part> 

A  else 

<program> 

procedure 

FOLLOW  SETS 

<declaration> 

type  id  procedure  begin  pack 

<object_decl> 

type  end  id  procedure  begin  pack 

<type_decl> 

type  end  id  procedure  begin  pack 

<subprog_decl> 

A  type  end  id  procedure  begin  pack 

<package_decl> 

type  id  procedure  begin  pack 

<id_list> 

colon 

<id _ list _ tail> 

colon 

<type_ind> 

semicolon  rparen 

<type_def> 

semicolon 

<stype_def> 

semicolon  rparen 

<array_def> 

semicolon 

<index_bd> 

rparen  dotdot 

<  record  _def> 

semicolon 

<index_range> 

rparen 

id  pkg_id 
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<comp_def> 

end 

<comp_def_tail> 

end 

<subprog_header> 

semicolon  is 

<  form  al_  part  > 

semicolon  is 

<subprog_part> 

semicolon 

<param_decl> 

rparen 

<sparam_decl> 

semicolon  rparen 

<p_tail> 

colon 

<mode> 

array  int  bool  char  record 

<p_dec_tail> 

rparen 

<decl_part> 

begin 

<pkg_tail> 

type  id  procedure  begin  pack 

<pkg_def_decl> 

type  id  procedure  begin  pack 

<pkg_d_decl> 

end 

<pkg_body_decl> 

type  id  procedure  begin  pack 

<pkg_b_ded> 

end 

<relational_op> 

semicolon  lparen  rparen  int _ lit  id  comma 

plus  minus  not  rec_id  then  loop  pkg_id  true 

false 

Cunary  _  add_op> 

lparen  int _ lit  id  not  rec_id  pkg_id  true  false 

<binary_add_op> 

lparen  int _ lit  id  not  rec_id  pkg_id  true  false 

<term> 

colon  semicolon  rparen  comma  eq  ne  It  le  gt 

ge  plus  minus  or  then  loop 

<mul_op> 

lparen  int  lit  id  not  rec  id  pkg_id  true  false 

<simp_expr> 

colon  semicolon  rparen  comma  eq  ne  It  le  gt 

ge  then  loop 

<sexp_tail> 

colon  semicolon  rparen  comma  eq  ne  It  le  gt 

ge  then  loop 

<factor> 

colon  semicolon  rparen  comma  eq  ne  It  le  gt 

ge  plus  minus  and  star  mod  div  or  then  loop 

<term_tail> 

colon  semicolon  rparen  comma  eq  ne  It  le  gt 

ge  plus  minus  or  then  loop 

<vbll> 

colon  semicolon  rparen  comma  eq  ne  It  le  gt 

ge  plus  minus  and  star  mod  div  or  then  loop 
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<vbl_tail> 

becomes 

colon  semicolon  rparen  comma  eq  ne  It  le  gt 

<vl_tail> 

ge  plus  minus  and  star  mod  div  or  then  loop 

dot  becomes 

colon  semicolon  rparen  comma  eq  ne  It  le  gt 

<vbl2> 

ge  plus  minus  and  star  mod  div  or  then  loop 

becomes 

colon  semicolon  rparen  comma  eq  ne  It  le  gt 

<vbl> 

ge  plus  minus  and  star  mod  div  or  then  loop 

colon  semicolon  rparen  comma  eq  ne  It  le  gt 

<expression> 

ge  plus  minus  and  star  mod  div  or  then  loop 

colon  semicolon  rparen  comma  then  loop 

<exp _ ta.il> 

colon  semicolon  rparen  comma  then  loop 

<statement> 

end  id  null  rec_id  proc_id  if  elsif  else  exit 

<lstatement> 

loop  while  pkg_id  write  writeln  read 

end  id  null  rec_id  proc_id  if  exit  loop  while 

<stat_seq> 

pkg_id  write  writeln  read 

end  elsif  else 

<lstat_seq> 

end 

<stat_seq_tail> 

end  elsif  else 

<lstat_seq_tail> 

end 

<simp_stat> 

semicolon 

<write_stat> 

semicolon 

<write_body> 

semicolon 

<w_tail> 

rparen 

<read_stat> 

semicolon 

<comp_stat> 

semicolon 

<pr°c_call_stat> 

semicolon 

<pk_stat> 

semicolon 

<pk_stat_tail> 

semicolon 

<assign_stat> 

semicolon 

<exit_stat> 

semicolon 

<exp_p_sub> 

rparen 

<p_call_tail> 

semicolon 
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<p_sub_tail> 

<if_stat> 

<loop_stat> 

<while_stat> 

<elsif_part> 

<else_part> 

<  program  > 


rparen 

semicolon 

semicolon 

semicolon 

end  else 

end 

A 


CHECKING  FOR  LL(1)  STRUCTURE 


SYNTAX  IS  LL(1) 

FIRSTSETS  OF  RIGHT  SIDES  OF  PRODUCTIONS 

1:  <declaration>  — >  <object_decl> 

First  set  is  [id] 

2:  <declaration>  — >  <type_decl> 

First  set  is  [type] 

3:  <declaration>  —  >  <subprog_decl> 

First  set  is  [procedure] 

4:  <declaration>  --->  <package_decl> 

First  set  is  [pack] 

5:  <object_decl>  — >  <id_list>  colon  <type_ind>  semicolon 
First  set  is  [id] 

6:  <type_decl>  — >  type  type_id  is  <type_def>  semicolon 
First  set  is  [type] 

7:  <subprog_decl>  — >  <subprog_header>  is  <subprog_part>  semicolon 
First  set  is  [procedure] 

8:  <package_decl>  —  >  pack  <pkg_tail> 

First  set  is  [pack] 

9:  <id _ list >  — ->  id  <id _ list _ tail> 

First  set  is  [id] 

10:  <id  list  tail >  — >  comma  id  <id  list  tail> 


page  21 


First  set  is  [comma] 

11:  <id _ list _ tail>  — >  /\ 

First  set  is  [lambdal] 

12:  <type_ind>  —  >  type_id 
First  set  is  [type_id] 

13:  <type_ind>  — >  <stype_def> 

First  set  is  [int, bool, char] 

14:  <type_def>  — >  <stype_def> 

First  set  is  [int, bool, char] 

15:  <type_def>  — >  <array_def> 

First  set  is  [array] 

16:  <type_def>  — >  <record_def> 

First  set  is  [record] 

17:  <stype_def>  — >  int 
First  set  is  [int] 

18:  <stype_def>  — >  bool 
First  set  is  [bool] 

19:  <stype_def>  — >  char 
First  set  is  [char] 

20:  <array_def>  — >  array  lparen  <index_range>  rparen  of  <type_ind> 
First  set  is  [array] 

21:  <index_bd>  — >  int _ lit 

First  set  is  [int _ lit] 

22:  <index_bd>  —  >  plus  int _ lit 

First  set  is  [plus] 

23:  <index_bd>  —  >  minus  int _ lit 

First  set  is  [minus] 

24:  <record_def>  — >  record  <comp_def>  end  record 
First  set  is  [record] 

25:  <index_range>  — >  <index_bd>  dotdot  <index_bd> 

First  set  is  [int _ lit , plus, minus] 

26:  <comp_def>  — >  <object_decl>  <comp_def_tail> 

First  set  is  [id] 

27:  <comp_def_taii>  —  >  <object_decl>  <comp_def_tail> 
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First  set  is  [id] 

28:  <comp_def_tail>  — >  /\ 

First  set  is  [lambdal] 

29:  <subprog_header>  —  >  procedure  id  <formaI_part> 

First  set  is  [procedure] 

30:  <formal_part>  — >  lparen  <param_decl>  rparen 
First  set  is  [lparen] 

31:  <formal_part>  —  >  /\ 

First  set  is  [lambdal] 

32:  <subprog_part>  — >  <decl_part>  begin  <stat_seq>  end 
First  set  is  [type, id, procedure, begin, pack] 

33:  <param_decl>  —  >  <sparam_decl>  <p_dec_tail> 

First  set  is  [id] 

34:  <sparam_decl>  — >  id  <p_tail>  colon  <mode>  <type_ind> 
First  set  is  [id] 

35:  <p_tail>  — >  comma  id  <p_tail> 

First  set  is  [comma] 

36:  <p_tail>  —  >  /\ 

First  set  is  [lambdal] 

37:  <mode>  —  >  in 
First  set  is  [in] 

38:  <mode>  — >  out 
First  set  is  [out] 

39:  <mode>  — >  /\ 

First  set  is  [lambdal] 

40:  <p_dec_tail>  — >  semicolon  <sparam_decl>  <p_dec_tail> 
First  set  is  [semicolon] 

41:  <p_dec_tail>  — >  /\ 

First  set  is  [lambdal] 

42:  <decl_part>  — ->  <declaration>  <decl_part> 

First  set  is  [type, id, procedure. pack] 

43:  <decl_part>  — >  /\ 

First  set  is  [lambdal] 

44:  <pkg  _tail>  — >  pkg_id  is  <pkg_def_decl> 
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First  set  is  [pkg _ id] 

45:  <pkg_tail>  — ->  body  pkg_id  is  <pkg_body_  decl> 

First  set  is  [body] 

46:  <pkg_def_decl>  — >  <pkg_d_decl>  end  pack  semicolon 
First  set  is  [type, end.id, procedure] 

47:  <pkg  d_decl>  — >  <object_decl>  <pkg_d_deci> 

First  set  is  [id] 

48:  <pkg_d_decl>  — >  <type_decl>  <pkg_d_decl> 

First  set  is  [type] 

49:  <pkg_d_decl>  —  >  <subprog_header>  semicolon  <pkg_d_decl> 
First  set  is  [procedure] 

50:  <pkg_d_decl>  — >  /\ 

First  set  is  [lambdaij 

51:  <pkg_body_decl>  — ->  <pkg_b_decl>  end  pack  semicolon 
First  set  is  [type,end, id, procedure] 

52:  <pkg_b_decl>  —  >  <object_decl>  <pkg_b_decl> 

First  set  is  [id] 

53:  <pkg_b_decl>  —  >  <type_decl>  <pkg_b_decl> 

First  set  is  [type] 

54:  <pkg_b  _decl>  — >  <subprog_decl>  <pkg_b_decl> 

First  set  is  [procedure] 

55:  <pkg_b_decl>  — >  /\ 

First  set  is  [lambdal] 

56:  <relational_op>  —  >  eq 
First  set  is  [eq] 

57:  <relational_op>  — ->  ne 
First  set  is  [ne] 

58:  <relational_op>  — >  It 
First  set  is  [It] 

59:  <relational_op>  —  >  !e 
First  set  is  [le] 

60:  <reiariona!_op>  — >  gt 
First  set  is  [gt] 

61:  <re!ational_op>  — >  ge 
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First  set  is  [ge] 

62:  <unary_add_op>  —  >  plus 
First  set  is  [plus] 

63:  <unary_add_op>  — >  minus 
First  set  is  [minus] 

64:  <unary_add_op>  —  >  /\ 

First  set  is  [lambdal] 

65:  <binary_add_op>  — >  plus 
First  set  is  [plus] 

66:  <binary_add_op>  — >  minus 
First  set  is  [minus] 

67:  <binary_add_op>  — >  or 
First  set  is  [or] 

68:  <term>  —  >  <factor>  <term_tail> 

First  set  is  [lparen,int_lit, id, not, rec_id,pkg_id,true, false] 

69:  <mul_op>  — >  star 
First  set  is  [star] 

70:  <mul_op>  — >  div 
First  set  is  [div] 

71:  <mul_op>  — >  mod 
First  set  is  [mod] 

72:  <mul_op>  — >  and 
First  set  is  [and] 

73:  <simp_expr>  — >  <unary_add_op>  <term>  <sexp_tail> 
First  set  is  [Iparen, int_iit, id, plus, minus, not, rec_id,pkg_id, true, 
false] 

74:  <sevp_tail>  —  >  <binary_add_op>  <term>  <sexp_tail> 
First  set  is  [plus, minus, or] 

75:  <sexp_tail>  — >  /\ 

First  set  is  [lambdal] 

76:  <factor>  — ->  int _ lit 

First  set  is  [int_!it] 

77:  <factor>  -->  Iparen  <expression>  rparen 
First  set  is  [Iparen] 
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78:  <factor>  —  >  <vbl> 

First  set  is  [id,rec_id,pkg_id] 

79:  <factor>  --->  not  <factor> 

First  set  is  [not] 

80:  <factor>  — ->  true 
First  set  is  [true] 

81:  <factor>  — ->  false 
First  set  is  [false] 

82:  <term_tail>  — ->  <mul_op>  <factor>  <term_tail> 

First  set  is  [and, star, mod, div] 

83:  <term_tail>  —  >  /\ 

First  set  is  [lambdal] 

84:  <vbll>  —  >  rec_id  <vl_tail> 

First  set  is  [rec_id] 

85:  <vbll>  — ->  id  <vbl_tail>  <vl_tail> 

First  set  is  [id] 

86:  <vbl_taii>  — >  lparen  <expression>  rparen  <vbl_tail> 

First  set  is  [lparen] 

87:  <vbl_tail>  — ->  /\ 

First  set  is  [lambdal] 

88:  <vl_tail>  — >  dot  <vbll> 

First  set  is  [dot] 

89:  <vl_tail>  — >  /\ 

First  set  is  [lambdal] 

90:  <vbl2>  — >  pkg_id  dot  <vbll> 

First  set  is  [pkg_id] 

91:  <vbl>  — >  <vbll> 

First  set  is  [id,rec_id] 

92:  <vbl>  —  >  <vbl2> 

First  set  is  [pkg _ id] 

93:  <expression>  — >  <simp_expr>  <exp_tail> 

First  set  is  [lambdal , lparen, int lit, id, plus, minus, not, rec_id,pkg_id, 

true, false] 

94:  <exp_tail>  — >  <relational_op>  <simp_expr> 
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First  set  is  [eq,ne,lt,le,gt,ge] 

95:  <exp_tail>  — >  /\ 

First  set  is  [lambdal] 

96:  <statement>  — >  <simp_stat>  semicolon 

First  set  is  [id, null, rec_id,proc_id,pkg_id, write, writeln, read] 

97:  <statement>  — >  <comp_stat>  semicolon 

First  set  is  [if, loop, while] 

98:  <lstatement>  — >  <statement> 

First  set  is  [id, null, rec_id,proc_id, if, loop, while, pkg_id, write, 

writeln, read] 

99:  <lstatement>  —  >  <exit_stat>  semicolon 
First  set  is  [exit] 

100:  <stat_seq>  — ->  <statement>  <stat_seq_tail> 

First  set  is  [id,null,rec_id,proc_id,if,loop,while,pkg_id,write, 

writeln,read] 

101:  <lstat_seq>  —  >  <lstatement>  <lstat_seq_tail> 

First  set  is  [id,null,rec_id.proc_id,if,exit,loop,while,pkg_id, 

write, writeln,read] 

102:  <stat_seq_tail>  — >  <statement>  <stat_seq_tail> 

First  set  is  [id,nuli,rec_id,proc_id,if,loop,while,pkg_id,write, 

writeln, read] 

103:  <stat_seq_tail>  — >  /\ 

First  set  is  [lambdal] 

104:  <lstat_seq_tail>  — >  <lstatement>  <lstat_seq_tail> 
First  set  is  [id, null, rec_id,proc_id, if, exit, loop, while, pkg_id, 

write, writeln, read] 

105:  <lstat_seq_tail>  — >  /\ 

First  set  is  [lambdal] 

106:  <simp_stat>  — >  null 
First  set  is  [null] 

107:  <simp_stat>  — >  <pk_stat> 

First  set  is  [pkg_id] 

108:  <simp_stat>  — >  <proc_call_stat> 

First  set  is  [proc_id] 
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109:  <simp_stat>  —  >  <assign_stat> 

First  set  is  [id,rec_id] 

110:  <simp_stat>  —  ->  <write_stat> 

First  set  is  [write, writeln] 

111:  <simp_stat>  — >  <read_stat> 

First  set  is  [read] 

112:  <write_stat>  — ->  write  <write_body> 

First  set  is  [write] 

113:  <write_stat>  — ->  writeln 
First  set  is  [writeln] 

114:  <write_body>  —  >  Iparen  <expression>  <w_tail>  rparen 
First  set  is  [Iparen] 

115:  <w_tail>  —  >  colon  <expression> 

First  set  is  [colon] 

116:  <w_tail>  — >  /\ 

First  set  is  [lambdal] 

117:  <read_stat>  — >  read  Iparen  id  rparen 
First  set  is  [read] 

118:  <comp__stat>  — >  <if_stat> 

First  set  is  [if] 

119:  <comp_stat>  —  >  <loop_stat> 

First  set  is  [loop] 

120:  <comp__stat>  --->  <while_stat> 

First  set  is  [while] 

121:  <proc_call_stat>  —  >  proc_id  <p_call_tail> 

First  set  is  [proc_id] 

122:  <pk_stat>  — >  pkg_id  dot  <pk_stat_tail> 

First  set  is  [pkg__id] 

123:  <pk_stat_tail>  --->  <proc_caIl_stat> 

First  set  is  [proc__id] 

124:  <pk_stat_tail>  — >  <assign_stat> 

First  set  is  [id,rec_id] 

125:  <assign_stat>  — >  <vbll>  becomes  <expression> 

First  set  is  [id,rec_id] 
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126:  <exit_stat>  — >  exit  when  <expression> 

First  set  is  [exit] 

127:  <exp_p_sub>  —  >  <expression>  <p_sub_taii> 

First  set  is  [iambdal,lparen,int_lit, id, plus, minus, not, rec_id,pkg_id, 

true, false] 

128:  <p_cali_tail>  — >  lparen  <exp_p_sub>  rparen 
First  set  is  [lparen] 

129:  <p_cail_tail>  — >  /\ 

First  set  is  [lambdal] 

130:  <p_sub_tail>  — >  comma  <exp_p_sub> 

First  set  is  [comma] 

131:  <p_sub_tail>  — >  /\ 

First  set  is  [lambdal] 

132:  <if_stat>  — >  if  <expression>  then  <stat_seq>  <elsif_part>  <else_part>  end  if 
First  set  is  [if] 

133:  <loop_stat>  — >  loop  <lstat_seq>  end  loop 
First  set  is  [loop] 

134:  <while__stat>  — >  while  <expression>  <loop_stat> 

First  set  is  [while] 

135:  <elsif_part>  — >  elsif  <expression>  then  <stat_seq> 

First  set  is  [elsif] 

136:  <elsif_part>  —  >  /\ 

First  set  is  [lambdal] 

137:  <else_part>  — >  else  <stat_seq> 

First  set  is  [else] 

138:  <else_part>  — >  /\ 

First  set  is  [lambdal] 

139:  <program>  —  >  <subprog_decl> 

First  set  is  [procedure] 
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2.  Pass  1:  Lexical  Analysis. 


This  pass  reflects  several  important  choices  made  for  the  ultimate  operation  of  the 
compiler.  First  and  foremost  the  compiler  was  developed  for  pedagogical  purposes  and  was  not 
intended  to  become  a  production  compiler  (although  the  latter  goal  could  be  offered  as  a 
future  student  project.)  This  means  that  the  error  reporting  system  would  be  quite  primitive. 
Second,  since  compilers  are  quite  complex  simplicity  was  made  a  major  w-atchword.  Thus  for 
example  we  chose  linear  search  rather  than  hashing.  Further  we  decided  not  to  maintain  a 
printname  table  for  error  reporting.  Error  reporting  could  be  done  simply  by  indicating  the  line 
the  error  is  on.  In  fact  an  extensive  error  diagnosis  sytem  was  implemented  but  this  was 
intended  for  use  by  the  impiementer  as  a  debugging  tool.  However,  this  diagnostic  tool  could 
eventually  be  turned  into  a  method  for  reporting  errors  to  the  user.  Thus,  all  identifiers  are 
turned  into  internal  symbols  and  the  later  passes  do  not  know  the  print  name.  Passl  produces 
two  files.  These  are  outl  which  is  used  by  Pass2  and  mneml  which  is  intended  to  be  used  by 
the  impiementer.  mneml  is  a  mnemonic  version  of  outl.  The  production  of  mneml  can  of 
course  be  disabled.  Passl  requests  the  name  of  the  source  file  and  then  produces  the  above  two 
files.  Since  passl  cannot  do  any  syntax  analysis  there  are  very  few  errors  which  it  can  report. 
About  the  only  error  of  consequence  to  the  lexical  analysis  is  an  illegal  symbol  in  the  syntax. 
The  files  outl  and  mneml  for  the  bubble  sort  program  presented  above  look  like  this: 

outl: 

19  1  51  7  57  39  19  2  40  7  58  39  35  9  8  0  38  8  25  10  44  33  11  19  3  40  7  59 
39  48  19  4  7  60  32  33  11  19  5  7  61  32  7  58  11  19  6  1  48  11  19  7  7  62  32 
33  11  19  8  7  63  32  7  59  11  19  9  19  10  47  7  64  39  19  11  51  7  65  9  7  66  32 
14  7  59  11  7  67  32  33  10  11  19  12  51  7  68  9  7  66  32  14  7  59  11  7  67  32  33 
10  11  19  13  51  7  69  9  7  66  32  14  7  59  10  11  19  14  1  47  11  19  15  19  16  47 
36  7  54  39  19  17  51  7  65  9  7  66  32  14  7  59  1 1  7  67  32  33  10  39  19  18  7  62 
32  33  11  19  19  0  19  20  7  66  2  7  60  4  7  67  11  19  21  7  62  4  8  1  11  19  22  50 
7  62  22  7  67  17  19  23  7  66  2  7  61  9  7  62  10  4  7  67  5  8  1  6  7  62  11  19  24 
7  62  4  7  62  5  8  1  11  19  25  1  17  11  19  26  1  11  19  27  19  28  51  7  68  9  7  66 
32  14  7  59  11  7  67  32  33  10  39  19  29  7  62  32  33  11  19  30  0  19  31  7  62  4 
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8  1  11  19  32  50  7  62  22  7  67  17  19  33  53  9  7  66  2  7  61  9  7  62  10  32  8  4 

10  11  19  34  7  62  4  7  62  5  8  1  11  19  35  1  17  11  19  36  1  11  19  37  19  38  51 

7  69  9  7  66  32  14  7  59  10  39  19  39  7  70  12  7  62  12  7  71  32  33  11  19  40  0 
19  41  7  62  4  8  2  11  19  42  50  7  62  22  7  66  2  7  60  17  19  43  7  66  2  7  61  9 

8  0  10  4  7  66  2  7  61  9  7  62  10  11  19  44  7  71  4  7  62  11  19  45  50  7  66  2  7 

61  9  7  71  10  21  7  66  2  7  61  9  7  71  6  8  1  10  17  19  46  7  70  4  7  66  2  7  61 

9  7  71  10  11  19  47  7  66  2  7  61  9  7  71  10  4  7  66  2  7  61  9  7  71  6  8  1  10  11 

19  48  7  66  2  7  61  9  7  71  6  8  1  10  4  7  70  11  19  49  7  71  4  7  71  6  8  1  11  19 

50  1  17  11  19  51  7  62  4  7  62  5  8  1  11  19  52  1  17  11  19  53  1  11  19  54  1  47 

11  19  55  19  56  0  19  57  7  64  2  7  65  9  7  63  12  8  8  10  11  19  58  7  64  2  7  69 
9  7  63  10  11  19  59  7  64  2  7  68  9  7  63  12  8  8  10  11  19  60  1  11  13 

mneml: 

linenol  1  prod  idl  57  isl  linenol  2  typel  id  1  58  isl  arrayl  Iparenthl 
intlitl  0  dotdotl  intlitl  25  rparenthl  ofl  inti  semicolonl  linenol 
3  typel  idl  59  isl  recordl  linenol  4  idl  60  colonl  inti  semicolonl 
linenol  5  idl  61  colonl  idl  58  semicolonl  linenol  6  endl  recordl 
semicolonl  linenol  7  idl  62  colonl  inti  semicolonl  linenol  8  idl 
63  colonl  idl  59  semicolonl  linenol  9  linenol  10  packl  idl  64  isl 
linenol  11  prod  idl  65  Iparenthl  idl  66  colonl  outl  idl  59  semicolonl 
idl  67  colonl  inti  rparenthl  semicolonl  linenol  12  prod  idl  68  Iparenthl 
idl  66  colonl  outl  idl  59  semicolonl  idl  67  colonl  inti  rparenthl 
semicolonl  linenol  13  prod  idl  69  Iparenthl  idl  66  colonl  outl  idl 
59  rparenthl  semicolonl  linenol  14  endl  packl  semicolonl  linenol 
15  linenol  16  packl  bodyl  idl  64  isl  linenol  17  prod  idl  65  Iparenthl 
idl  66  colonl  outl  idl  59  semicolonl  idl  67  colonl  inti  rparenthl 
isl  linenol  18  idl  62  colonl  inti  semicolonl  linenol  19  beginl  linenol 

20  idl  66  dotl  idl  60  becomesl  idl  67  semicolonl  linenol  21  idl  62 
becomesl  intlitl  1  semicolonl  linenol  22  whilel  idl  62  le2  idl  67 

loopl  linenol  23  idl  66  dotl  idl  61  Iparenthl  idl  62  rparenthl  becomesl 
idl  67  plusopl  intlitl  1  minusopl  idl  62  semicolonl  linenol  24  idl 

62  becomesl  idl  62  plusopl  intlitl  1  semicolonl  linenol  25  endl  loopl 
semicolonl  linenol  26  endl  semicolonl  linenol  27  linenol  28  prod 
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id  1  68  Iparenthl  idl  66  colonl  outl  idl  59  semicolonl  idl  67  colonl 
inti  rparenthl  isl  iinenol  29  idl  62  colonl  inti  semicolonl  linenol 
30  beginl  linenol  31  idl  62  becomesl  intlitl  1  semicolonl  linenol 
32  whilel  idl  62  le2  idl  67  loopl  linenol  33  writel  Iparenthl  idl 
66  dotl  idl  61  Iparenthl  idl  62  rparenthl  colonl  intlitl  4  rparenthl 
semicolonl  linenol  34  idl  62  becomesl  idl  62  plusopl  intlitl  1  semicolonl 
linenol  35  endl  loopl  semicolonl  linenol  36  endl  semicolonl  linenol 
37  linenol  38  prod  idl  69  Iparenthl  idl  66  colonl  outl  idl  59  rparenthl 
isl  linenol  39  idl  70  commal  idl  62  commal  idl  71  colonl  inti  semicolonl 
linenol  40  beginl  linenol  41  idl  62  becomesl  intlitl  2  semicolonl 
linenol  42  whilel  idl  62  le2  idl  66  dotl  idl  60  loopl  iinenol  43 
idl  66  dotl  idl  61  Iparenthl  intlitl  0  rparenthl  becomesl  idl  66 
dotl  idl  61  Iparenthl  idl  62  rparenthl  semicolonl  linenol  44  idl 
71  becomesl  idl  62  semicolonl  linenol  45  whilel  idl  66  dotl  idl  61 
Iparenthl  idl  71  rparenthl  ltl  idl  66  dotl  idl  61  Iparenthl  idl  71 
minusopl  intlitl  1  rparenthl  loopl  linenol  46  idl  70  becomesl  idl 
66  dotl  idl  61  Iparenthl  idl  71  rparenthl  semicolonl  linenol  47  idl 
66  dotl  idl  61  Iparenthl  idl  71  rparenthl  becomesl  idl  66  dotl  idl 
61  Iparenthl  idl  71  minusopl  intlitl  1  rparenthl  semicolonl  linenol 
48  idl  66  dotl  idl  61  Iparenthl  idl  71  minusopl  intlitl  1  rparenthl 
becomesl  idl  70  semicolonl  linenol  49  idl  71  becomesl  idl  71  minusopl 
intlitl  1  semicolonl  linenol  50  endl  loopl  semicolonl  linenol  51 
idl  62  becomesl  idl  62  plusopl  intlitl  1  semicolonl  linenol  52  endl 
loopl  semicolonl  linenol  53  endl  semicolonl  linenol  54  endl  packl 
semicolonl  linenol  55  linenol  56  beginl  linenol  57  idl  64  dotl  idl 
65  Iparenthl  idl  63  commal  intlitl  8  rparenthl  semicolonl  linenol 

58  idl  64  dotl  idl  69  Iparenthl  idl  63  rparenthl  semicolonl  linenol 

59  idl  64  dotl  idl  68  Iparenthl  idl  63  commal  intlitl  8  rparenthl 
semicolonl  linenol  60  endl  semicolonl  endtextl 

The  code  for  passl  is  now  listed.  At  this  point  and  for  the  future  we  make  no 
apologies  for  the  infelicities  of  code.  Though  we  have  made  every  effort  to  maintain  good 
design  engineering  practices  we  are  certain  that  some  awkward  code  occurs.  However  given  the 
fact  that  we  had  little  time  to  carefully  reexamine  the  compiler  most  of  the  code  appears  to  be 
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in  reasonable  shape.  As  always,  understanding  code  which  you  have  not  participated  in  writing 
is  difficult.  We  hope  the  reader  will  make  the  necessary  effort  to  see  the  point  our  programs. 

with  text_io; 

package  int_io  is  new  text_io.integer_io(integer); 

with  text_io;  with  int _ io; 

procedure  passl  is 
rsrvtop:  constant  :=  32; 
symstart:  constant  :=  56; 
endtable:  constant  ;=  55; 

type  symbols  is  (beginl,  endl,  dotl,  elsifl,  becomes!.,  plusopl,  —5 
minusopl,idl,  intlitl,  lparenthl,  rparenthl,  --10 
semicolon!.,  commal,  endtextl,  outl,  ifl,  —15 
thenl,  loopl,  exitl,  linenol,  errorl,  It  1,  lei,  —22 
gtl,  gel,  eql,  nel  ,  starl,  slashl,  andl,  —29 
orl,  notl,  colonl,  inti,  booil,  arrayl,  -35 
bodyl,  charl,  dotdotl,  isl,  typel,  truel,  falsel,-42 
elsel,  ofl,  modi,  nulll,  packl,  recordl,  -48 
whenl,  whilel,  prod,  ini,  writel,  writelnl,  readl);  —55 

type  errors  is  (numerical,  unknown2); 
nm_error:  exception; 
subtype  strll  is  string(l  ..  11); 
subtype  str80  is  string(l  ..  80); 
subtype  str20  is  string(l  ..  20); 

mnem:  array(integer  range  0. .endtable)  of  strll; 
type  symrec  is  record 

wd:  strll; 
lnth:  integer; 
val:  integer; 
end  record; 

symboltable:  array(integer  range  0  ..  60)  of  symrec; 
progfile,  foutl,  listfile,  mnfile:  text_io.fi!e_type; 
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ch:  character;  x:  integer; 

line:  array(integer  range  1  ..  80)  of  character;  cc,  lc:  integer; 
sym:  symbols;  idno,  lineno:  integer; 
outlen,  mnemlen,  linenum:  integer; 
type  wordrec  is  record 

len:  integer; 
wrd:  strSO; 
end  record; 

word:  wordrec;  symtop:  integer; 
endfile:  boolean; 

procedure  init  is 

term:  symbols;  i:  integer; 

begin 

mnem(0)  :=  ”beginl  ”; 
mnem(l)  ;=  ”endl 
mnem(2)  :=  ”dotl 
mnem(3)  :=  ’’elsifl  ”; 
mnem(4)  :=  "becomesl  ”; 
mnem(5)  :=  ’’plusopl 
mnem(6)  :=  "minusopl 
mnem(7)  :=  ”idl 
mnem(8)  :=  ’’intlitl 
mnem(9)  :=  ’’Iparenthl  ”; 
mnem(10)  :=  ’’rparenthl  ”; 
mnem(ll)  :=  ’’semicolonl  ”; 
mnem(12)  :=  ’’commal  ”; 
mnem(13)  :=  ’’endtextl  ”; 
mnem(14)  :=  ”outl  ”; 

mnem(15)  :=  ”ifl  ”; 
mnem(16)  :=  ”thenl 
mnem(17)  :=  ”loopl  ”; 

mnem(18)  :=  ”exitl 
mnem(19)  :=  ’’linenol  ”; 
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mnem(20)  := 

”errorl 

99  , 

> 

mnem(2l)  := 

”ltl 

«  . 

9 

mnem(22)  := 

”le2 

99 . 

» 

mnem(23)  := 

”gtl 

r* , 

5 

mnem(24)  := 

”gel 

99  . 

1 

mnem(25)  := 

”eql 

99  , 

9 

mnem(26)  := 

”nel 

99  . 

J 

mnem(27)  := 

”starl 

99  . 

9 

mnem(28)  := 

’’slash  1 

99  . 

9 

mnem(29)  . - 

”andl 

» 

mnem(30)  := 

”orl 

99  . 

9 

mnem(31)  := 

”notl 

99  . 

9 

mnem(32)  := 

’’colonl 

99  . 

1 

mnem(33)  := 

”intl 

99  . 

9 

mnem(34)  := 

’’booll 

V  . 

9 

mnem(35)  := 

’’arrayl 

99, 

9 

mnem(36)  := 

’’bodyl 

99  , 

9 

mnem(37)  := 

”charl 

99  . 

9 

mnem(38)  := 

”dotdotl 

99  . 
9 

mnem(39)  := 

”isl 

99  . 

9 

mnem(40)  := 

’’typel 

99  . 

9 

mnem(41)  := 

’’truel 

99  . 

9 

mnem(42)  := 

”  false  1 

99  . 

9 

mnem(43)  := 

’’elsel 

99  . 

9 

mnem(44)  := 

”ofl 

99  . 

9 

mnem(45)  := 

’’modi 

99  . 

9 

mnem(46) 

’’nulll 

99  . 

9 

mnem(47)  := 

”packl 

M  . 

J 

mnem(48)  := 

” record  1 

n . 

» 

mnem(49)  := 

”whenl 

99  , 

9 

mnem(50)  :  — 

”whilel 

99  . 

9 

mnem(51)  := 

”procl 

99  . 

9 

mnem(52)  := 

”inl 

99  . 

9 

mnem(53)  := 

’’writel 

99  . 

page  35 


mnem(54)  :=  "writelnl  ” 
mnem(55)  :=  ”readl 


symboltable(O)  := 
symboltable(l)  := 
symboltable(2)  := 
symboitable(3)  := 
symboltable(4)  := 
symboltable(5)  := 
symboltable(6)  := 
symboltable(7)  := 
symboltable(S)  := 
symboltable(9)  := 
symboltable(lO)  := 
symboltable(ll)  := 
symboltable(12)  := 
symboltable(13)  := 
symboltable(14)  := 
symboltable(15)  := 
symboltable(16)  := 
symboltable(17)  := 
symboltable(18)  := 
symboltable(19)  := 
symboltable(20)  := 
symboltabIe(21)  := 
symboltable(22)  := 
symboltable(23)  := 
symboltable(24)  := 
symboltable(25)  := 
symboltable(26)  :  = 
symboltable(27)  := 
symboltable(28)  := 
symboltable(29)  := 
symboltabie(30)  := 


("begin 

”,5,  0); 

("end 

”,3,  1); 

("else 

”,4,  43); 

("elsif 

”,5,  3); 

("out 

”,3,  14); 

("if 

”,2,  15); 

("then 

”»4,  16); 

("loop 

”>4,  17); 

("exit 

”,4,  18); 

("and 

”,3,  29); 

("or 

”,2,  30); 

("not 

’\3,  31); 

("int 

",3,  33); 

("bool 

”,4,  34); 

("array 

”,5,  35); 

("is 

”,2,  39); 

("type 

n>4>  40); 

("true 

M,  41); 

("false 

",5,  42); 

("body 

”,4,  36); 

("char 

”,4,  37); 

("of 

’\2,  44); 

("mod 

”,3,  45); 

("null 

”,4,  46); 

("pack 

’’,4,  47); 

("record 

”,6,  48); 

("when 

”,4,  49); 

("while 

”,5,  50); 

("proc 

”,4,  51); 

("in 

”,2,  52); 

("write 

”,5,  53); 
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symboltable(31)  :=  (’’writeln  ”,7,  54); 
symboltable(32)  :=  (’’read  ”,4,  55); 

idno  :=  symstart; 
outlen  :=  0;  mnemlen  :=  0; 
linenum  :=  0; 

symtop  :=  rsrvtop;  endfile  :=  false; 
end; 


function  size(n:  integer)  return  integer  is 
neg:  boolean;  nn,  len:  integer; 
begin 
nn  :=  n; 

neg  :=  (nn  <  0); 
if  neg  then  nn  :=  -nn;  end  if; 
if  nn  <=  9  then  len  :=  1; 
elsif  nn  <=  99  then  len  :=  2; 
elsif  nn  <=  999  then  len  :=  3; 
elsif  nn  <=  9999  then  len  :=  4; 
elsif  nn  <=  32767  then  len  :=  5; 
end  if; 

if  neg  then  return  len  *f  1; 
else  return  len;  end  if; 
end  size; 

procedure  emit(n:  integer)  is 

sz:  integer; 

begin 

sz  :=  size(n); 

text_io.put(foutl,’  ’);  int_io.put(foutl,n,  sz); 
outlen  :=  outlen  +  sz  +  1; 
if  outlen  >=  72  then 
text_io.put_line(foutl,””); 


page  37 


outlen  :=  0; 
end  if  ; 
end  emit; 

function  ]ength(st:  strll)  return  integer  is 
i:  integer; 
begin 
i  :=  11; 

while  st(i)  =  ’  ’  loop 
i  :=  i  -  1; 
end  loop; 
return  i; 
end; 

procedure  emitl(k,n:  integer)  is 

lngth,  sz:  integer; 

begin 

if  k  =  1  then 

lngth  :=  Iength(mnem(n)); 
emit(n); 

text_io.put(mnfile,  ’  ’&  mnem(n)(l  ..  lngth)); 
mnemlen  :=  mnemlen  -f  lngth  +  1; 
if  mnemlen  >=  65  then 
text_io.put_line(mnfile,””); 
mnemlen  :=  0; 
end  if; 
else 

emit(n); 
sz  :=  size(n); 

text_io.put(mnfile,’  ’);  int_io.put(mnfile,n,sz); 
mnemlen  :=  mnemlen  +  sz  +  1; 
if  mnemlen  >=  65  then 
text_io.put_Iine(mnfile,””); 
mnemlen  :=  0: 
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end  if; 
end  if; 
end  emitl; 


procedure  emit2(m,n:integer)  is 
begin 

emitl(l,m);  emitl(2,n); 
end; 

procedure  error(k:  integer)  is 
begin 

emit2(symbols’pos(errorl),  k); 
end; 

procedure  nextchfkh:  out  character)  is 

i  :  integer; 

begin 

if  (cc  =  1c)  and  text_io.end_of_file(progfile)  then 
endfile  :=  true;  kh  :=  ’  ’; 
else 

—  else  begins  here 

if  (cc  =  lc)  and  (not  text_io.end_of_file(progfile))  then 
i  :=  0; 

while  not  text_io.end_of_line(progfile)  loop 

i  :=  i  +  1; 

text_io.get(progfile,  ch); 
text_io.put(listfile,  ch); 
if  (’A’  <=  ch)  and  (ch  <=  ’Z’)  then 
line(i)  :  = 

character’val(c'iaracter’pos(ch)  -  character’pos(’A’) 
+  character’po$(  V)); 

else 

line(i)  :=  ch; 
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end  if; 
end  loop; 
lc  :=  i  +  1; 
line(lc)  :=  ’  '; 
cc  :=  0; 

text_io.skip_line(progfile); 
text_io.new_line(listfile); 
linenum  :=  linenum  -f  1; 
emit2(sy  mbols’pos(linenol ), linen  um); 
end  if; 

cc  cc  +  1; 
kh  :=  line(cc); 

—  else  ends  here 
end  if; 
end; 


procedure  getfile  is 
use  text_io; 

subtype  str30  is  string(l  ..  30); 

fn:str30;  i:  natural; 

begin 

put(” program  file  >  ”); 
get_line(standard_input,fn,  i); 
open(progfile,in_file,  fn(l  ..  i)); 
create(listfile,out_  file, ’’lister”); 
create(foutl,out_file,”outl”); 
create(mnfile,out_file,  ’’mnernl”); 
exception 

when  name_error  =  > 

put_line(”File  ”  &  fn(l  ..  i)  &  ”  Not  Found”); 
raise  nm_error; 

end: 
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procedure  getnumber(n:  integer)  is 

value:  integer; 

begin 

value  :=  0; 
loop 

if  (value  <=  3276)  or  ((value  =  3276)  and  (ch  <=  ’7’))  then 
value  :=  10  *  value  +  character’pos(ch) 

-  character’pos(’O’); 
nextch(ch); 
else 

error(errors’pos(numerical2)); 

while  (’O’  <=  ch)  and  (ch  <=  ’9’)  loop  nextch(ch);  end  loop; 
value  :=  0; 
end  if; 

exit  when  (ch  <  ’O’)  or  (’9’  <  ch); 
end  loop; 

em:t2(sy.Tibols’pos(intlitl),  n  *  value); 
end; 

procedure  get  word  is 

i:  integer; 

begin 

i  :=  0; 

loop 

i  :=  i  +  1; 

word.wrd(i)  :=  ch; 
nextch(ch); 

exit  when  not  (  ((’a’  <=  ch)  and  (ch  <=  V))  or 
((’O’  <=  ch)  and  (ch  <=  ’9’))  ); 
end  loop; 
if  i  >=  20  then 
word.len  :=  20; 
else 

word.len  :=i; 
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end  if; 
end; 

function  check(oldwd,  nuwd:  wordrec)  return  boolean  is 

i,  len:  integer;  ok:  boolean; 

begin 

len  :=  nuwd. len; 
if  len  =  oldwd.len  then 
i  :=  1; 
ok  :=  true; 
while  ok  loop 

ok  :=  oldwd.wrd(i)  =  nuwd.wrd(i); 
if  ok  then 

>  :=  i  +  1; 

ok  :=  i  <=  len; 
end  if; 
end  loop; 
return  i  >  len; 
else  return  false; 
end  if; 
end; 

procedure  insert(j:  integer)  is 

i:  integer; 

begin 

for  i  in  1  ..  word. len  loop 
symboltable(j).wd(i)  :=  word.wrd(i); 
end  loop; 

symboltable(j).lnth  :=  word. len; 
idno  :=  idno  +  1; 
symboltable(j).val  :=  idno; 
end; 

procedure  findword  is 
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ij,  k:  integer;  oldwd:  wordrec; 
begin 

j  :=  symtop; 

j  :=  j  +  l; 

insert(j); 
i  :=  -1; 
loop 

i  :=  i  +  1; 

oldwd. len  :=  symboltable(i).lnth; 
for  k  in  1  ..  oldwd. len  loop 
oldwd. wrd(k)  :=  symboltable(i).wd(k); 
end  loop; 

exit  when  check(oldwd,  word); 
end  loop; 

if  i  <=  rsrvtop  then 
emitl(l,symboltab!e(i).val); 
else 

emit2(symbols’pos(idl),  symboltable(i).val); 
end  if; 
if  i  <  j  then 
idno  :=  idno  -  1; 
else 

symtop  :=  j; 
end  if; 
end; 

procedure  nextsym  is 
begin 

while  (ch  =  ’  ’)  and  (not  endfile)  loop  nextch(ch);  end  loop; 
if  not  endfile  then 

if  (V  <=  ch)  and  (ch  <=  V)  then 
get  word; 
findword; 

elsif  (’O’  <=  ch)  and  (ch  <=  ’9’)  then 
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getnumber(l); 

else 

case  ch  is 

when  Y  =>  emitl(l,symbols’pos(commal));  nextch(ch); 
when  Y  =>  emit  1(1, symbols’pos(semicolonl));  nextch(ch); 
when  ’(’  =  >  emitl(l,symbols’pos(lparenthl));  nextch(ch); 
when  ’)’  =>  emitl(l,symbols’p°s(rparenthl));  nextch(ch); 
when  =>  emitl(l,symbols’pos(plusopl));  nextch(ch); 
when  V  =>  emitl(l,symbois’pos(starl));  nextch(ch); 
when  =>  emitl(l,symbols’pos(minusopl));  nextch(ch); 
when  ’/’  => 

nextch(ch); 
if  ch  =  ’=’  then 
emitl(l,symbols’pos(nel)); 
nextch(ch); 
else 

emitl(l,symbols’pos(slashl)); 
end  if; 
when  V  => 

nextch(ch); 
if  ch  =  ’=’  then 

emit  1  ( 1  ,sy  m  bols  ’pos(  becomes  1 ) ) ; 
nextch(ch); 
else 

emit  1(1,  sym  bols’pos(colonl  )); 
end  if; 

when  ’<’  => 

nextch(ch); 
if  ch  =  then 
emitl(l,  symbols’pos(lel)); 
nextch(ch); 
else 

emitl(l,  symbols’pos(ltl)); 
end  if; 
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when  ’>’  => 

nextch(ch); 
if  oh  =  ’=’  then 
emitl(l,  symbols’pos(gel)); 
nextch(ch); 
else 

emitl(l,  symbols’pos(gtl)); 
end  if; 

when  ’=’  => 

emitl(l,  symbols’pos(eql)); 
nextch(ch); 
when  => 

nextch(ch); 
if  ch  =  V  then 

emitl(l,  symbols’pos(dotdotl)); 
nextch(ch); 
else 

emitl(l,symbols’pos(dotl)); 
end  if; 

when  others  =>  error(errors’pos(unknown2));  nextch(ch); 
end  case; 
end  if; 
end  if; 
end; 

begin  -  micl 
init; 
getfile; 
cc  :=  0; 

lc  :=  0;  ch  :=  ’  ’; 
while  not  endfile  loop 
nextsym; 
end  loop; 

emitl(l,symbols’pos(endtextl)); 
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text_io.close(listfile); 

text_io.close(foutl); 

text_io.close(mnfile); 

exception 

when  nm_error  =>  null; 
end  passl; 
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3.  Pass2:  Parsing,  Scope  and  Context  Analysis. 


The  syntax  given  for  our  language  is,  as  is  frequently  done  in  compiling,  a  ‘fake’ 
LL(1)  syntax.  This  means  that  while  the  syntax  is  formally  LL(1)  so  that  the  syntax  analysis 
works  properly  the  actual  language  is  context  sensitive.  This  is  true  of  virtually  all  compiler 
languages  which  are  purported  to  be  context  free.  In  fact  such  issues  as  not  allowing  duplicate 
declarations  of  variables  or  distinguishing  between  assignment  statements  or  procedure  calls 
while  using  a  one  look-ahead  parsing  algorithm  are  contextual  matters.  The  literature, 
however,  usually  refers  to  these  matters  as  ‘static  semantics’.  With  the  exception  of  type 
declarations  these  are  generally  not  semantical  issues  but  a  way  of  restricting  to  a  context 
sensitive  subset  of  the  languages  given  by  our  syntax.  The  restrictions,  as  we  have  stated  are 
mostly  contextual  in  nature  at  this  point.  The  usual  way  to  manage  most  of  these  restrictions, 
including  type  declarations,  is  by  means  of  a  symbol  table.  (Sometimes  these  contextual 
restrictions  are  managed  in  an  ad  hoc  manner,  viz.  the  handling  of  the  dangling  else  in  Pascal.) 
By  use  of  a  symbol  table  and  a  set  of  rules  usually  given  in  a  language  reference  manual  the 
contextual  restrictions  can  be  imposed  in  this  pass. 

For  the  most  part  we  follow  the  Ada  restrictions  but  there  are  a  few  exceptions. 
Some  of  these  are 

1)  We  do  not  allow  packages  to  be  nested  within  packages.  For  pedagogical  reasons 
this  is  an  unnecessary  complication.  Moreover  we  suspect  that  in  practice  it  is  rarely  done. 
One  the  other  hand,  since  we  allow  packages  to  be  declared  within  procedures  and  procedures 
within  packages  we  have  an  indirect  way  of  nesting  packages. 

2)  Parameters  to  procedures  follow  the  Pascal  rules.  That  is  the  default  is  IN  or  IN 
may  be  declared  explicitly.  This  is  like  the  Ada  IN,  but  in  our  case  the  variable  becomes,  as  in 
Pascal,  an  unrestricted  local  variable  in  the  procedure.  The  OUT  declaration  follows  the 
specification  of  the  Pascal  VAR  parameter.  That  is  it  replaces  both  the  Ada  OUT  and  the  Ada 
IN  OUT. 

3)  Precedence  in  expressions  follow  the  Pascal  rules.  These  are  easy  to  implement 
using  LL(1)  parsing  techniques. 

4)  There  is  no  FOR  statement.  However  the  WHILE  statement  and  the  LOOP 
statement  with  exits  have  been  implemented.  Here  we  follow  the  philosophy  of  [H] . 

5)  Records  have  been  introduced  but  the  record  variant  yields  a  complication  which 
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which  made  it  necessary  to  omit  it. 

6)  High  dimensional  arrays  are  introduced  but  only  as  arrays  of  arrays.  This  is 
reasonably  practical. 

7)  Any  typing  of  an  identifier  must  be  done  by  means  of  a  type  identifier  which  has 
been  previously  defined.  This  simplifies  considerably  the  type  analysis.  Thus  one  cannot  define 

xx:  array(0  ..  10)  of  int; 
one  must  do  it  in  the  following  way: 

type  list  is  array(0  ..  10)  of  int; 

xx:  list; 

8)  The  only  basic  types  available  in  the  compiler  are  integer  and  boolean.  At  first  it 
was  thought  to  introduce  character  types  but  this  was  abandoned. 

9)  Even  though  this  is  not  really  part  of  the  scope  analysis  it  is  necessary  to  point 
out  here  that  I/O  is  very  primitive. 

The  main  feature  of  this  pass  is  the  symbol  table.  Here  we  decided  to  maintain 
simplicity  and  use  only  one  table.  That  is  all  identifiers  would  be  on  the  table  as  well  as  all 
types,  procedures  and  packages.  No  other  tables  were  introduced.  This  provided  a  uniform 
treatment  for  identifiers  but  had  the  disadvantage  that  the  record  entries  on  the  table  would 
be  large.  However  it  was  felt  that  space  was  not  a  serious  consideration.  Additionally  to  avoid 
complications  Ada’s  variant  records  were  not  used  in  our  symbol  table.  The  record  structure 
for  the  symbol  table  is  shown  below. 

type  item  is  record 

bkwrd,  fwrd,  lvl:  integer; 
id_name:  integer; 
kind:  idkind; 
typ:  typekind; 
trans:  modekind; 
typ_point,  pk_pt:  integer; 
param_end,  sect_end:  integer; 

end  record; 

The  symbol  table  is  then  declared  as 
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symbol_ table:  array(0  ..  symtop)  of  item; 

The  structure  of  the  symbol  table  is  that  of  a  stack,  in  fact,  a  multistack.  The 
structure  of  the  language  is  organized  into  sections.  Sections  are  started  by  procedures,  records 
and  packages.  Each  section  defines  a  locality.  When  the  section  start  is  entered  on  the  symbol 
table  the  entry  sect_end  keeps  track  of  the  last  identifier  declared  in  that  section.  Each  item 
in  the  section  points  back  to  the  previous  item  of  the  section  and  thus  the  sections  can  be 
searched  backwards.  The  two  parts  of  a  package  both  appear  on  the  table  and  the  package 
body  has  a  pointer,  pk_pt  which  points  to  the  item  for  the  initial  package  declaration.  Thus 
when  the  package  body  is  completed  the  initial  package  declaration  can  be  searched  to  see  if 
its  declared  procedure  heads  appear  in  the  package  body.  In  addition  data  declared  in  the  in 
intial  package  definition  can  also  be  found  for  use  in  the  body.  Types  appear  as  items  and  an 
identifier  of  a  given  type  points  back  to  the  type  item.  Consider  the  following  program: 

proc  aaa  is 
x,  y:  bool; 
type  bb  is  record 
uu:  bool; 
x:  int; 
end  record; 

type  11  is  array(0  ..  4)  of  bb; 
proc  bbb(u:  11)  is 
begin 
null; 
end; 

pack  ccc  is 

proc  ddd  (x:  int;  y:  out  11); 
proc  eee  (y:  bb); 
end  pack; 

proc  fff  is 
kk:  11; 
begin 

ccc.ddd(3,  kk); 
end; 
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pack  body  ccc  is 
proc  ddd  (x:  int;  y:  out  11)  is 
a:  bb; 
begin 
null; 
end; 

proc  eee  (y:  bb)  is 
uvw:  bool; 
begin 
null; 
end; 
vv:  int; 

proc  ee(y:  bb)  is 
begin 
null; 
end; 

end  pack; 

begin 

null; 

end; 

A  partial  view  of  its  symbol  table  is 


inx 

name  type 

typpt 

bkwrd 

sect_end 

id_name 

1 

-1 

proc3 

-1 

0 

5 

2 

33 

int3 

-1 

1 

30463 

3 

34 

bool3 

-1 

2 

7154 

4 

37 

char3 

-1 

3 

0 

5 

57 

proc3 

30326 

4 

22 

aaa 

6 

58 

bool3 

3 

5 

25186 

X 
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7 

59 

bool3 

3 

6 

8224 

y 

8 

60 

rec3 

8 

7 

10 

bb 

9 

61 

bool3 

3 

8 

28192 

uu 

10 

58 

int3 

2 

9 

28793 

X 

11 

62 

array3 

8 

8 

13344 

11 

12 

63 

proc3 

29296 

11 

13 

bbb 

13 

64 

array3 

11 

12 

3438 

u 

14 

65 

pkg_def3 

8224 

12 

18 

ccc 

15 

66 

proc3 

2573 

14 

17 

ddd 

16 

58 

int3 

2 

15 

30063 

X 

17 

59 

array3 

11 

16 

8293 

y 

18 

67 

proc3 

25710 

15 

19 

eee 

19 

59 

rec3 

8 

18 

2573 

y 

20 

68 

proc3 

8224 

14 

21 

fff 

21 

69 

array3 

11 

20 

27499 

kk 

22 

65 

pkg_bdy3  3338 

20 

31 

ccc 

23 

66 

proc3 

2573 

22 

26 

ddd 

24 

58 

int3 

2 

23 

30063 

X 

25 

59 

array3 

11 

24 

3387 

y 

26 

70 

rec3 

8 

25 

27756 

a 

27 

67 

proc3 

2573 

23 

29 

eee 

28 

59 

rec3 

8 

27 

8224 

y 

29 

71 

bool3 

3 

28 

26983 

uvw 

30 

72 

int3 

2 

27 

7876 

vv 

31 

73 

proc3 

2 

30 

32 

ee 

32 

59 

rec3 

8 

31 

-20749 

y 

The  entries  with  large  numbers  are  uninitialized  garbage  entries.  Notice  that  the 
section  end  of  aaa  at  line  5  is  22.  A  backward  search  from  22  ccc  (body)  yields  20  fff,  14  ccc 
(decl),  12  bbb,  11  11,  8  bb,  7  y,  6  x,  5  aaa.  Inside  this  section  we  find,  for  example  the  section 
starting  at  line  14  whose  section  end  is  18.  Using  this  multistack  arrangement  we  are  able  to 
keep  track  of  all  of  the  localities  of  the  program. 

The  other  main  feature  of  pass2  is  of  course  the  parsing.  We  have  chosen  panic 
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parsing  as  can  be  found,  for  example  in  Turbo  Pascal.  The  program  of  pass2  iollows: 
with  text_io; 

package  int_io  is  new  text_io.integer_io(integer); 
with  text_io;  with  int_io; 
procedure  pass2  is 
symtop:  constant  :=  500; 

type  symbols  is  (beginl,  endl,  dotl,  elsifl,  becomesl,  plusopl,  -5 
minusopl,idl,  intlitl,  lparenthl,  rparenthl,  -10 
semicolonl,  commal,  endtextl,  outl,  ifl,  —15 
thenl,  loopl,  exitl,  linenol,  errorl,  It  1 ,  lei,  —22 
gtl,  gel,  eql,  nel  ,  starl,  slashl,  andl,  —29 
orl,  notl,  colonl,  inti,  booll,  arrayl,  -35 
bodyl,  charl,  dotdotl,  isl,  typel,  truel,  falsel,— 42 
elsel,  ofl,  modi,  nulll,  packl,  recordl,  —48 
whenl,  whilel,  procl,  ini,  writel,  writelnl,  readl);  -55 

type  typekind  is  (int3,  bool3,  char3,  array3,  rec3,  proc3,  pkg_def3, 

Pkg„bdy3,  notyp3); 

type  idkind  is  (obj4,  typ_id4,  param4,  proc_id4,  pkg_id4,  unknown_id4); 
int_pt,  bool_pt,  char_pt:  integer; 

type  modekind  is  (in5,  out5); 

infil,  fout2,  listfile,  mnfile:  text_io.file_type; 
sym:  symbols; 

i,  linenum,  secondsym,  errposn  :  integer; 
endfile:  boolean; 
type  item  is  record 

bkwrd,  fwrd,  Ivl:  integer; 
id_name:  integer; 
kind:  idkind; 
typ:  typekind; 
trans:  modekind; 
typ_point,  pk_pt:  integer; 
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param_end,  sect_end:  integer; 
end  record; 

symbol_table:  array(0  ..  symtop)  of  item; 
double,  invisible:  array(symbols)  of  boolean; 
levmax:  constant  :=  25; 

display:  array(integer  range  -1  ..  levmax)  of  integer; 
subtype  strll  is  string(l  ..  11); 
subtype  str20  is  string(l  ..  2u); 
subtype  str8  is  string(l  ..  8); 
err_excep:  exception; 
table_pt:  integer; 
seciion_start:  integer; 
type  q__item  is  record 
idk:  idkind; 
pi:  integer; 
end  record; 

pkg_d_stack:  array(l  ..  100)  of  integer; 
pkg_d_pt:  integer; 

package  debug  is 
tmnem:  array(typekind)  of  str8; 
procedure  emit(n:  integer); 
function  length(st:  strll)  return  integer; 
procedure  emitl(k,n:  integer); 
procedure  emit2(m,n:integer); 
procedure  error(m,k:  integer); 
end  debug; 

package  body  debug  is 

endmntable:  constant  :=  55; 
outlen,  mnemlen:  integer; 

mnem:  array(integer  range  0.. endmntable)  of  strll; 
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function  size(n:  integer)  return  integer  is 
neg:  boolean;  nn,  len:  integer; 
begin 
nn  n; 

neg  :=  (nn  <  0); 
if  neg  then  nn  :=  -nn;  end  if; 
if  nn  <=  9  then  len  :=  1; 
elsif  nn  <=  99  then  len  :=  2; 
elsif  nn  <=  999  then  len  :=  3; 
elsif  nn  <=  9999  then  len  :=  4; 
elsif  nn  <=  32767  then  len  :=  5; 
end  if; 

if  neg  then  return  len  +  1; 
else  return  ten;  end  if; 
end  size1 

procedure  emit(n:  integer)  is 

sz:  integer; 

begin 

sz  :=  size(n); 

text_io.put(fout2,’  ’);  int_io.put(fout2,n,  sz); 
outlen  :=  outlen  +  r-  -f  1; 
if  outlen  >=  72  then 
text_io.put_line(fout2,”” ); 
outlen  :=  0; 
end  if  ; 
end  emit; 

function  length(st:  strll)  return  integer  is 
i:  integer; 
begin 
i  :=  11; 

while  st(i)  =  ’  ’  loop 

i  ~  i  -  1; 
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end  loop; 
return  i; 
end; 

procedure  emitl(k,n:  integer)  is 

Ingth,  sz:  integer; 

begin 

if  k  =  1  then 

Ingth  :=  length(mnem(n)); 
emit(n); 

text_io.put(mnfiIe,  ’  mnem(n)(l  ..  Ingth)); 
mnemlen  mnemlen  +  Ingth  +  1; 
if  mnemlen  >=  65  then 
text_io.put_line(mnfile,””); 
mnemlen  :=  0; 
end  if; 
else 

emit(n); 
sz  :=  size(n); 

text_io.put(mnfile,’  ’);  int_io.put(mnfile,n,sz); 
mnemlen  :=  mnemlen  -f  sz  +  1; 
if  mnemlen  >=  65  then 
text_io.put_line(mnfile,””); 
mnemlen  :=  0; 
end  if; 
end  if; 
end  emitl; 


procedure  emit2(m,n:integer)  is 
begin 

emitl(l,m);  emitl(2,n); 
end; 
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procedure  error(m,k:  integer)  is 
begin 

emit2(symbols’pos(errorl),  m); 
errposn  :=  m; 
raise  err_excep; 
end  error; 


begin  —package  debug  initialization  section 


mnem(O) 

mnem(l) 

mnem(2) 

mnem(3) 

mnem(4) 

mnem(5) 

mnem(6) 

mnem(7) 

mnem(8) 

mnem(9) 

mnem(10) 

mnem(ll) 

mnem(12) 

mnem(13) 


=  ”  begin  1 
=  ”endl 
=  ”dotl 
=  ’’elsifl 
=  ”  becomes  1 
=  ’’plusopl 
=  ’’minusopl 
=  ”idl 
=  ’’intlitl 
=  ’’Iparenthl 
=  ’’rparenthl 
=  "semicolon  1 
=  "commal 
=  ’’endtextl 


rnnem(14)  := 

”outl 

n 

mnem(  15) 

”ifl 

M  . 

1 

mnem(16)  := 

”thenl 

71 

mnem(17)  := 

"loopl 

71 

mnem(18) 

”exitl 

17  . 
1 

mnem(19)  := 

’’linenol 

17 

mnem(20) 

’’errorl 

17 

mnem(21 )  := 

”ltl 

71  . 

1 

mnem(22)  := 

”le2 

77  , 

1 

mnem(23)  := 

"gtl 

71  , 

1 

mnem(24)  := 

"gel 

71  , 

7 

mnem(25) 

”eql 

77. 

1 
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mnem(26)  := 

”nel 

Yi  . 

1 

mnem(27)  := 

”starl 

«  . 

» 

mnem(28)  := 

"slashl 

* 

mnem(29)  := 

”andl 

n  . 

» 

mnem(30)  := 

”orl 

yy , 

» 

mnem(31)  := 

”notl 

y 

mnem(32)  := 

”  colon  1 

M . 

y 

mnem(33)  := 

”intl 

M  . 

y 

mnem(34)  := 

”  booll 

n , 

mnem(35)  := 

’’arrayl 

yy . 
y 

mnem(36)  := 

"bodyl 

» . 
> 

mnem(37)  := 

’’charl 

yy . 

» 

mnem(38)  := 

’’dotdotl 

yy  . 
> 

mnem(39)  := 

”isl 

1 

mnem(40)  := 

”typel 

”  . 
y 

mnem(41)  := 

”truel 

yy , 

) 

mnem(42)  := 

”  false  1 

yy . 
y 

mnem(43)  := 

”elsel 

yy . 

mnem(44)  := 

”ofl 

yy . 
y 

mnem(45)  := 

’’modi 

yy 

y 

mnem(46)  := 

”nulll 

yy . 
y 

mnem(47)  := 

”packl 

yy . 
i 

mnem(48)  := 

” record  1 

w . 
y 

mnem(49)  := 

”whenl 

yy 

mnem(50)  := 

’’whilel 

yy . 
j 

mnem(51)  := 

’’prod 

yy . 
y 

mriern(52)  := 

”inl 

yy . 

* 

mnem(53)  := 

”writel 

yy . 

» 

mnem(54)  := 

”writelnl 

yy . 
y 

mnem(55)  := 

” read  1 

yy . 
y 

outlen  :=  0;  mnemlen  :=  0; 
tmnem  :=  (”int3  ”,  ”bool3  ”,  ”char3  ”, 
”array3  ”,  ”rec3  ”,  ”proc3  ”,  ”pkg_def3”, 
”pkg_bdy3”,  ”notyp3  ”); 
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end  debug; 


package  initialize  is 
procedure  init; 
end  initialize; 

package  body  initialize  is 
procedure  init  is 
begin 

for  ss  in  symbols  loop 
double(ss)  :=  false; 
invisible(ss)  :=  false; 
end  loop; 

double(idl)  :=  true; 
double(intlitl)  :=  true; 
double(linenol)  :=  true; 
double(errorl)  :=  true; 
invisible(linenol)  :=  true; 
invisible(errorl)  :=  true; 

Pkg_d_pt  :=  0; 
end  init; 
begin 
init; 

end  initialize; 

procedure  getfile  is 
use  text_io; 
begin 

open(infil,in_file,”outl”); 
create(listfile, out  _file,”  lister”); 
create(fout2,out_file,”out2”); 

—  The  file  mnem2  is  used  for  debugging  purposes. 

—  It  can  be  eliminated  later. 
create(mnfile,  out_file,  ”mnem2”); 
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text_io.put_line(mnfile,”pass2.ada  mnem2”); 
text_io.new_line(mnfile); 
end; 


procedure  nextsym  is 
firstsym:  integer; 
use  int_io; 
begin 

get(infil, firstsym); 
sym  :=  symbols’val(firstsym); 
while  invisible(sym)  loop 
debug.emitl(l,  firstsym); 
get(infil,  secondsym); 
debug.emitl(2,  secondsym); 
if  sym  =  linenol  then 
linenum  :=  secondsym; 
elsif  sym  =  errorl  then 
debug.error(l,  secondsym); 
end  if; 

get(infil,  firstsym); 
sym  :=  symbols’val(firstsym); 
end  loop; 

debug.emit  1(1, firstsym); 
if  double(sym)  then 
get(infil,  secondsym); 
debug.emitl(2,  secondsym); 
end  if; 

end  nextsym; 

package  b_entry  is 

procedure  basic_entry(id,tpt:  integer; 

knd:idkind;  tp:typekind); 

end  b_entry; 
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package  body  b_entry  is 
procedure  basic_entry(id,tpt:  integer; 

knd:idkind;  tprtypekind)  is 

begin 

table_pt  :=  table_pt  +  1; 

symbol_table(table_pt).bkwrd  :=  table_pt  -  1; 
symbol_table(table_pt).id_name  id; 
symbol_table(table_pt).lvl  :=  -1; 
symbol_table(table_pt).kind  :=  knd; 
symbol_table(table_pt).typ  :=  tp; 
symbol_table(table_pt).typ_point  :=  tpt; 
end; 

begin  —  b_entry 
table_pt  :=  0;  display(-l)  :=  1; 
basic_entry(-l,  -1,  proc_id4,  proc3); 

basic_entry(symboIs’pos(intl),  -1,  typ_id4,  int3);  int_pt  :=  table_pt; 
basic_entry(symbols’pos(booll),  -1,  typ_id4,  booi3);  bool_pt  :=  table_pt; 
basic_entry(symbols’pos(charl),  -1,  typ_id4,  char3);  char_pt  :=  table_pt; 
symboI_table(l).sect_end  :=  4; 
end  b_entry; 

procedure  checksym(symb:  symbols;  n:  integer)  is 
begin 

if  syrn  =  symb  then  nextsym; 
else  debug.error(n,symbols’pos(sym));  end  if; 
end; 

procedure  checksemi(n:  integer)  is 
begin 

checksym(semicolonl,n); 

end; 
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procedure  show__table  is 
begin 

text_io.put_line(”  inx  name  type  typpt  bwrd  sctnd”); 
for  i  in  1  ..  table_pt  loop 
int_io.put(i,3); 

int_io.put(symbol_table(i).id_name,9); 
text_io.put(”  ”); 

text_io.put(debug.tmnem(symbol_table(i).typ)); 
int__io.put(symbol_table(i).typ_point,7); 
int__io.put(symbol_table(i).bkwrd,7); 
int_io.put(symbol_table(i).sect_end,7); 
text  _io.  new  _  line; 
end  loop; 
end: 

procedure  enter_var(iden,  iv:  integer;  knd:  idkind)  ;s 

j,  k:  integer; 

begin 

table_pt  :=  table_pt  +  1; 
symbol_table(table_pt).bkwrd  := 

symbol  _table(display(lv)). sect  _end; 
symboI_table(tabie_pt).id_name  :=  iden; 
symbol_table(table_pt).lvl  :=  lv; 
symbol_tabIe(table_pt;.kind  knd; 
symbol_table(table_pt).typ  :=  notyp3; 
symbol_table(display(lv)).sect_end  :=  table_pt; 
symbol_table(table_pt).pk_pt  :=  -1; 
end; 

procedure  one_sect_check(ss,tp:  integer;  pi:  out  integer)  is 
temp,  j:  integer; 

—  checks  a  section  for  an  id 
begin 

temp  :=  symbo!_table(tp).bkwrd;  —  New  code 
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symbol_table(tp).bkwrd  :=  0;  —  New  code 
symbol_table(0).id_name  :=  ss; 
j  :=  symbol_table(tp).sect_end; 
while  symbol_table(j).id_name  /=  ss  loop 
j  :=  symbol_table(j).bkwrd; 
end  loop; 

symbol_table(tp).bkwrd  :=  temp; 
pl  :=  j; 

end; 


procedure  check_new_id(n,  ss,  Ivl:  integer;  pl  :  out  integer)  is 

temp,  j,  k,  pp,  tp:  integer; 

begin 

tp  :=  display(lvl); 
symbol_table(0).id_name  :=  ss; 
one_sect_check(ss,tpj); 

-  If  the  section  is  a  pack  body  then  special  conditions  prevail. 

-  For  object  variables  and  type  variables  check_new_id  should  consider 
--  the  pack  def  as  part  of  the  search  domain.  In  the  case  of  procedures 

—  however  check_new_id  should  only  search  within  the  pack  body.  A  second 

—  check  later  will  verify  that  the  pack  def  procedures  have  a  body, 
if  n  =  1  then 

if  (j  =  0)  and  (symbol_tabIe(tp).typ  =  pkg_bdy3)  then 
pp  :=  symbol_table(display(lvl)).pk_pt; 
one_sect_check(ss,  pp,  k); 
end  if; 
end  if; 

pl  “  j; 

end; 


function  id_index(id,  Ivl:  integer)  return  integer  is 

Iv,  Ink,  temp,  tp,  pp:  integer; 

begin 
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lv  :=  Ivl;  sy m bol _  table( 0 ) .id _ name  :=  id; 
loop 

tp  :=  display(lv); 
one_sect_check(id,tp,lnk); 

if  (Ink  —  0)  and  (symbol_table(tp).typ  =  pkg_bdy3)  then 
pp  :=  symbol_table(tp).pk_pt; 
one_sect_check(id,pp,lnk); 
end  if; 
lv  :=  lv  -  1; 

exit  when  (lv  <  -  1)  or  (Ink  /=  0); 
end  loop; 
return  Ink; 
end; 

procedure  id _ list _ tail(lvl:  integer)  is 

place:  integer; 
begin 

if  sym  =  commal  then 
nextsym; 
if  sym  =  idl  then 

check_new_id(l,  secondsym,lvl,  place); 
if  place  =  0  then  enter_var(secondsym,lvl,obj4); 
else  debug.error(7,symbols’pos(idl));  end  if; 
nextsym; 

else  debug.error(8,symbols’pos(idl));  end  if; 

id _ list _ ta.il(l  vl); 

else 

—  test  follow  symbols  for  id _ list _ tail 

if  sym  /=  colon  1  then  debug. error(6,symbols’pos(colonl)); 
end  if; 
end  if; 
end; 

procedure  id _ list(lvl:  integer)  is 
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place  :  integer; 
begin 

if  sym  =  idl  then 

check_new_id(l,  secondsym,  Ivl,  place); 
if  place  =  0  then  enter_var(secondsym,lvl,obj4); 
else  debug.error(5,symbols’pos(idl));  end  if; 
nextsym; 

else  debug.error(6,symbols’pos(idl));  end  if; 

id _ list _ tail(lvl); 

end; 

procedure  type_ind(lvl:  integer;  tp:  out  integer)  is 

j:  integer; 

begin 

case  sym  is 
when  idl  => 

j:=  id_index(secondsym,  lvl); 
if  j  =  0  then  debug.error(9,symbols’pos(idl)); 
elsif  symbol_table(j).kind  /=  typ_id4  then 
debug. error(  10, sy  mbols’pos(id  1 ) ); 
else  tp  :=  j; 
end  if; 
nextsym; 
when  inti  => 

tp  :=  2;  nextsym; 
when  booll  => 

tp  :=  3;  nextsym; 
when  charl  => 

tp  :=  4;  nextsym; 
when  others  => 

debug.  error(  11,  symbols’pos(idl)); 
end  case; 
end; 


page  64 


procedure  fill_type(st,  fin,  tp:  integer)  is 

tt:  typekind; 

begin 

tt  :=  symbol_tab!e(tp).typ; 
for  i  in  st  ..  fin  loop 
symbol_table(i).typ_point  :=  tp; 
symbol_table(i).typ  :=  tt; 
end  loop; 
end; 

procedure  object_decl(lvl:  integer)  is 
strt_pt,  end_pt,  tp_pt:  integer; 
begin 

strt_pt  :=  table_pt  +  1; 

id _ list(lvl); 

end_pt  :=  table_pt; 
checksym(coIonl,  3); 
type_ind(lvl,tp_pt); 
fill_type(strt_pt,  end__pt,  tp_pt); 
checksemi(4); 
end; 

procedure  stype_def(ivl:  integer)  is 

se:  integer; 

begin 

se  :=  symbol_table(display(lvl)).sect_end; 
case  sym  is 

when  inti  =>  symbol_table(se).typ_point  :=  in t _ pt; 

symbol_table(se).typ  :=  int3; 
when  booll  =>  symbol_table(se).typ_point  :=  bool_pt; 

symbol_table(se).typ  :=  bool3; 
when  charl  =>  symbol_table{se).typ_point  :=  char_pt; 
symbol_table(se).typ  :=  char3; 
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when  others  =>  debug.error(17,  symbols’pos(typel)); 
end  case; 

nextsym;  --  this  placement  of  nextsym  would  not  be 
—  correct  if  this  were  not  a  panic  parser. 

—  Where  should  it  go? 

end; 

procedure  index_bd(val:  out  integer)  is 
begin 

case  sym  is 
when  intlitl  => 
val  :=  secondsym: 
nextsym; 
when  plusopl  => 
nextsym; 

if  sym  =  intlitl  then 
val  :=  secondsym; 
nextsym; 
else 

debug. error(230,  symbols’pos(intlitl)); 
end  if; 

when  minusopl  =  > 
nextsym; 

if  sym  =  intlitl  then 
val  :=  -  secondsym; 
nextsym; 
else 

debug.error(230,  symbols’pos(intlitl)); 
end  if; 

when  others  => 

debug.error(231,symbols’pos(intlitl)); 
end  case; 
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procedure  index_range  is 
low,  high:  integer; 
begin 

index_bd(low); 
checksym(dotdotl,  23); 
index_bd(high); 

if  high  <  low  then  debug.error(26,  symbols’pos(arrayl)); 
end  if; 
end; 

procedure  array_def(lvi:  integer)  is 

tp,  j:  integer; 

begin 

checksym(arrayl,  18); 
checksym(lparenthl,  10); 
index_range; 
checksym(rparenthl,  21); 
checksym(ofl,  20); 
type_ind(lvl,  tp); 

j  :=  symbol_tabIe(display(lvl)).  sect_end; 
symbol_table(j).typ_point  ;=  tp; 
symbol_table(j).typ  :=  array3; 
end; 

procedure  comp_def_tail(lvl:  integer)  is 
begin 

if  sym  =  idl  then  --  is  the  first  symbol  of  object_decl 
object_decl(lvl); 
comp_def_tail(Ivl); 

elsif  sym  j—  endl  then  --  takes  care  of  follow  symbols 
debug.error(29,symbols’pos(idl)); 
end  if; 
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procedure  comp_dcf(lvl:  integer)  is 
begin 

object_decl(lvl); 

comp_def_tail(lvl); 

end; 

procedure  record_def(lvl:  integer)  is 

temp:  integer;  tp:  integer; 

begin 

checksym(recordl,  25); 
symbol_table(table_pt).typ  :=  rec3; 
tp  :=  table_pt; 

symbol_table(tp).sect_end  :  =  tp; 
symbol_table(tp).typ_point  :=  tp; 
display(lvl-f  1)  :=  tp; 
comp_def(lvl-fl); 
checksym(endl,  27); 
checksym(recordl,  28); 
symbol_tabie(tp).sect_end  :=  table_pt; 
end; 

procedure  type_def(lvl:  integer)  is 
begin 

case  sym  is 

when  inti  j  booll  |  charl  =>  stype_def(lvl); 
when  arrayl  =>  array_def(lvl); 
when  recordl  =>  record_def(lvI); 
when  others  =>  debug.error(16,symbois’pos(typel)); 
end  case; 
end; 

procedure  type_decl(lvl:  integer)  is 

pi:  integer; 

begin 
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checksym(typel,12); 
if  sym  =  idl  then 

check_new_id(l,  secondsym,ivI,  pi); 
if  pi  j—  0  then 

debug.error(13,symbols’pos(idl)); 

else 

enter_var(secondsym,  Ivl,  ;yp_id4); 
end  if; 
nextsym; 
else 

debug. error(  14, symbols’pos^idl)); 
end  if; 

checksym(isl,14); 

type_def(lvl); 

checksemi(15); 

end; 

procedure  mode(md:  out  modekind)  is 
begin 

case  sym  is 

when  ini  =>  md  :=  in5;  nextsym; 
when  outl  =>  md  :=  out5;  nextsym; 

—  deal  with  follow  symbols 

when  idl  |  inti  |  booll  |  charl  =>  md  ;=  in5; 

when  others  =>  debug.error(46,symbo!s’pos(typel)); 
end  case; 
end; 

procedure  p _ tail(lvl:  integer)  is 

place:  integer; 
begin 

if  sym  =  commal  then 
checksym(commal  ,40); 
if  sym  =  id  1  then 
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check_new_id(2,  secondsym,  lv!,  place); 
if  place  =  0  then  enter_var( secondsym, lvl,param4); 
else  debug. error(41,symbols’pos(idl ));  end  if; 
nextsym; 
p _ tail(lvl); 

else  debug.error(42,symbo!s’pos(idl));  end  if; 
elsif  sym  /=  colon  1  then 

debug.error(43,  symbols’pos(idl)); 
end  if; 
end; 

procedure  sparam_decl(lvl:  integer)  is 
strt_pt,  end_pt,  tp,  i:  integer;  ttrtypekind; 
md:  modekind;  place:  integer; 
begin 

if  sym  =  idl  then 

check_new_id(2,  secondsym,  lvl,  place); 
if  place  =  0  then 

strt_pt  :=  table_pt  -f  1; 
enter_var(secondsym,lvl,param4); 
else  debug.error(37,symbols’pos(idl));  end  if; 
nextsym; 

else  debug.error(38,symbols’pos(idl));  end  if; 

p _ taii(lvl); 

end_pt  :=  table_pt; 
checksym(colonl,39); 
mode(md); 

type _ ind(lvl,  tp); 

tt  :=  symbol_table(tp).typ; 
for  i  in  strt_pt  ..  end_pt  loop 
symbol_table(i).typ_point  :=  tp; 
symbol_table(i).typ  :=  tt; 
symbol_table(i).trans  :=  md; 
end  loop; 
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—  semicolon  check  is  done  in  p_dec_tai! 
end; 

procedure  p_dec_tail(lvl:  integer)  is 
begin 

if  sym  =  semicolon  1  then 
checksemi(44); 
sparam_decl(lvl); 

p _ dee _ ta.il(l  yl); 

elsif  sym  /=  rparenthl  then 
debug.error(45,  symbols’pos(rparenthl)); 
end  if; 
end; 

procedure  param_decl(lvl:  integer)  is 
begin 

sparam_decl(lvl); 

p_dec_tail(lvl); 

end; 

procedure  formal_part(lvl:  integer)  is 
begin 

if  sym  =  lparenthl  then 
checksym(lparenthl,35); 
param_decl(lvl); 
checksym(rparenthl.36); 
elsif  sym  /=  semicolonl  and  sym  /=  isl  then 
debug. error(37,symbols’pos(procl)); 
end  if; 
end; 

procedure  subprog_header(ivl:  integer)  is 

pi,  tp:  integer; 

begin 
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checksym(procl,32); 
if  sym  =  idl  then 

check_new_id(2,  secondsym,lvl,  pi); 
if  pi  /=  0  then 

debug.error(33,symbols’pos(idl)); 

else 

tp  :=  table_pt  +  1; 
enter_var(secondsym,  lvl,  proc_id4); 
symbol_table(tp).sect_end  :=  tp; 
symbol_table(tp).param_end  :=  tp; 
symbol_table(tp).typ  :=  proc3; 
end  if; 
nextsym; 
else 

debug.error(34,symbols’pos(idl)); 
end  if; 

display(lvl-t-l)  :=  tp; 
formal_part(lvl-f  1); 
symbol_table(tp).param_end  := 
symbol_table(tp).sect_end; 
end; 

procedure  expression(lvl:  integer;  typ_pt:  out  integer); 

procedure  vbl(lvl:  integer,  *yp_pt:  out  integer); 

procedure  factor(lvl:  integer;  typ_pt:  out  integer)  is 

tpt:  integer; 

begin 

case  sym  is 
when  intlitl  => 
typ_pt  :=  int_pt; 
nextsym; 

when  Iparenthl  => 
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nextsym; 

expression(Ivl,  typ_pt); 
checksym(rparenthl,  160); 

when  idl  =>  vbl(lvl,  typ_pt); 
when  notl  =  > 
nextsym; 
factor(lvl,  tpt); 
if  tpt  /=  bool_pt  then 
debug. error(  161,  symbols’pos(notl )); 
else 

typ_pt  bool_pt; 
end  if; 

when  truel  j  falsel  => 
nextsym; 

typ_Pt  :=  bool_pt; 

when  others  =>  debug.error(162,symbols’pos(idl)); 
end  case; 
end; 

procedure  term_tail(lvi,  typ  pt:  integer)  is 
tptl,  tpt2:  integer;  arith_op:  boolean; 
begin 

case  sym  is 

when  andl  |  starl  |  modi  |  slashl  => 
if  sym  =  andl  then 
tptl  :=  bool__pt; 
else 

tptl  :=  int_pt; 
end  if; 

if  typ_pt  /=  tptl  then 
debug.error(163,  symbols’pos(andl)); 
else 

nextsym; 
factor(lvl,  tpt2); 
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if  tpt2  /=  typ_pt  then 
debug.error(164,  symbols’pos(andl)); 
end  if; 

term_tail(ivl,typ_pt); 
end  if; 

when  coionl  |  semicoionl  |  rparenthl  |  commal  |  eql  |  nel 
ltl  |  lei  |  gtl  j  gel  |  plusopl  |  minusopl  |  orl  | 
thenl  |  loopl  =>  null; 

when  others  =>  debug. error(165,  symbols’pos(andl)); 
end  case; 
end; 

procedure  term(lvl:  integer;  typ_pt:  out  integer)  is 

tpt:  integer; 

begin 

factor(lvl,  tpt); 
term__tail(lvl,tpt); 
typ_pt  :=  tpt; 
end; 

procedure  sexp_tail(lvl,  typ_pt:  integer)  is 

tptl,  tpt2:  integer; 

begin 

case  sym  is 

when  plusopl  j  minusopl  |  orl  => 
if  sym  =  orl  then 
tptl  :=  bool_pt; 
else 

tptl  :=  int _ pt; 

end  if; 

if  typ_pt  /=  tptl  then 
debug. error(  166,  symbols’pos(orl)); 
else 

nextsym; 
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term(lvl,  tpt2); 
if  typ_pt  j—  tpt2  then 
debug. error(  167, symbols’pos(orl)); 
end  if; 

sexp_tail(lvl,  tpt2); 
end  if; 

when  colonl  |  semicolonl  |  rparenthl  |  commal  |  eql  |  nel  | 
ltl  |  lei  |  gtl  |  gel  |  thenl  |  loopl  =>  null; 
when  others  => 

debug.error(168,  symbols’pos(orl)); 

end  case; 
end; 

procedure  simp_expr(lvl:  integer;  typ_pt:  out  integer)  is 

tptl,  tpt2:  integer;  aflag:  boolean; 

begin 

case  sym  is 

when  plusopl  |  minusopl  => 
aflag  :=  true; 
nextsym; 
when  others  => 
aflag  :=  false; 
end  case; 
term(lvl,  tptl); 

if  aflag  and  (tptl  /—  int_pt)  then 
debug.error(169,  symbols’pos(plusopl)); 
end  if; 

sexp_tail(lvl,tptl); 
typ_pt  •  =  tptl; 
end; 

procedure  exp_tail(lvl:  integer;  typ_pt:  in  out  integer)  is 

tpt:  integer;  bfiag:  boolean; 

begin 
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case  sym  is 

when  eql  |  nel  |  Itl  j  lei  |  gtl  |  gel  => 
nextsym; 

simp_expr(lvl,  tpt); 
if  typ_pt  I—  tpt  then 
debug.  error(  171,  sym  bols’pos(eql)); 
elsif  (tpt  j—  int_pt)  and  (tpt  /=  bool_pt)  then 
debug.error(300,symbols’pos(eql)); 
else 

typ_pt  bool_pt; 
end  if; 

when  colonl  |  semicolonl  |  rparenthl  |  commal  |  thenl  j  loopl  => 
null; 

when  others  => 

debug.error(172,symbols’pos(eql)); 
end  case; 

end; 

procedure  expression(lvl:  integer;  typ_pt:  out  integer)  is 

tptl,  tpt2:  integer; 

begin 

simp_expr(lvl,  tptl); 
tpt2  :=  tptl; 
exp_tail(lvl,  tpt2); 
typ_pt  :=  tpt2; 
end; 

procedure  vbl_tail(lvi:integer;  typ_pt:  in  out  integer)  is 

tpt:  integer; 

begin 

case  sym  is 
when  lparenthl  => 
checksym(lparenthl,  120); 
expression(lvl,  tpt); 
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if  tpt  /=  int_pt  then 
debug. error(  121, symbols’pos(idl)); 
end  if; 

checksym(rparenthl,  140); 

typ_pt  :=  symbol_table(typ_pt).typ_point; 
vbl_tail(lvl,typ_pt); 

when  colonl  |  semicolonl  |  rparenthl  |  commal  |  eql  |  nel  j 
ltl  |  lei  |  gtl  |  gel  j  plusopl  |  minusopl  |  andl  | 
starl  |  modi  |  slashl  |  orl  |  thenl  j  loopl  |  dotl  |  becomesl 
=  >  null;  —  typ_pt  remains  unchanged 
when  others  => 

debug.error(122,  symbols’pos(idl)); 
end  case; 
end; 

procedure  vbll(lvl,  pi:  integer;  typ_pt:  out  integer); 

procedure  vl_tail(lvl,  pi,  plO:  integer;  typ_pt  rout  integer)  is 

pH,  pI2:  integer; 

begin 

case  sym  is 
when  dotl  => 

checksym(dotl,117); 
if  sym  /=  idl  then 
debug.error(119,  symbots’pos(id  1 )); 
else 

pH  :=  symbol_table(pl).typ_point; 
one_sect_check(secondsym,pll,pl2); 
vbll(lvl,pl2,typ_pt); 
end  if; 

when  colonl  \  semicolonl  |  rparenthl  |  commal  |  eql  |  nel  |  ltl  |  lei  | 
gtl  |  gel  |  plusopl  [  minusopl  |  andl  |  starl  |  modi  | 
slashl  |  orl  |  thenl  |  loopl  |  becomesl  =>  typ_pt  :=  plO; 
when  others  =>  debug. error(205,  symbols!pos(id  1 )); 
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end  case; 
end; 


procedure  vbll(lvl,  pi:  integer;  typ_pt:  out  integer)  is 

dummy,  tptl,  tpt2:  integer; 

begin 

dummy  :=  0; 
if  sym  /=  idl  then 
debug.error(113,  symbols’pos(idl)); 

else 

nextsym; 

case  symbol_table(pl).typ  is 
when  rec3  =  > 

tptl  :=  symbol_table(pl).typ_point; 
vl_tail(lvl,  pi,  tptl,  tpt2); 
typ_pt  :=  tpt2; 
when  int3  => 

vbl__tail(lvl,  dummy); 
typ_pt  :=  int_pt; 
when  boo!3  =  > 

vbl_tail(lvl,  dummy); 
typ_pt  :=  bool_pt; 
when  array3  =  > 

tptl  :=  symbol_table(pl).typ_point; 
vbl_tail(Ivl,tptl); 
vl_tail(lvl,  tptl,  tptl,  tpt2); 
typ_pt  ;=  tpt2; 

when  others  =>  debug. error(141,symbols’pos(idl)); 
end  case; 
end  if; 

end; 

procedure  vb!2(lvl,  pi:  integer;  typ_pt:  out  integer)  is 
pll:  integer; 


page  78 


begin 

if  sym  /=  idl  then 
debug.  error(  125,  symbols’pos(id  1 )); 
elsif  symbol_table(pl).kind  /—  pkg_id4  then 
debug.error(126,symbols’pos(idl)); 
else 

nextsym; 

checksym(dotl,  127); 
if  sym  /=  idl  then 
debug.error(128,  symbols’pos(idl)); 
else 

one_sect_check(secondsym,pl,pll); 
vbll(lvl,  pll,  typ_pt); 
end  if; 
end  if; 
end; 

procedure  vbl(lvl:  integer;  typ_pt:  out  integer)  is 

pi,  pll:  integer; 

begin 

if  sym  /=  idl  then 
debug.error(130,  symbols’pos(id  1 )); 
else 

pi  :=  id_index(secondsym,  Ivl); 
case  symbol_table(pl).kind  is 
when  obj4  j  param4  =>  vbl  1  ( I vl ,  pi,  typ_pt); 
when  pkg__id4  => 
pll  :=  symbol_table(pl).pk_pt; 
vb!2(lvl,  pll,  typ_pt); 

when  others  =>  debug. error(131,  symbols’pos(idl)) 
end  case; 
end  if; 
end; 
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procedure  exit_stat(lvl:  integer)  is 

tpt:  integer; 

begin 

checksym(exit  1,103); 
checksym(  when  1,104); 
expression(lvl,tpt); 

if  symbol_table(tpt).typ  j—  bool3  then 
debug.error(105,symbols’pos(booll)); 
end  if; 
end; 

procedure  p_sub_tail(!vl,  pi,  plO:  integer); 

procedure  exp_p_sub(lvl,  pi,  pi  1 :  integer)  is 

tptl,  pl2:  integer; 

begin 

if  symbol_table(pll).kind  j—  param4  then 
debug. error(  190, symbols’pos(idl)); 
elsif  symbol_table(pll).trans  =  in5  then 
expression(lvl,  tptl); 

if  symbol_table(pll).typ_  point  /=  tptl  then 
debug.error(191,  symbols’pos(idl)); 
else 

p_sub_tail(lvl,  pi,  pH); 
end  if; 

elsif  symbol_table(pll).trans  =  out5  then  —redundant  check 
vbl(lvl,  tptl); 

if  symbol_table(p!l).typ_point  j—  tptl  then 
debug.error(195,  symbols’pos(idl)); 
else 

p_sub_  tail(lvl,  pi,  pH); 
end  if; 
end  if; 
end; 
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procedure  p_sub_tail(lvi,  pi,  plO:  Integer)  is 

tptl,  pH,  pl‘2:  integer; 

begin 

case  syin  is 
when  commal  => 
nextsym; 
pll  :=  plO  +  1; 

if  symbol_table(pl).param_end  <  pll  then 
debug.error(189,  symbols’pos(idl)); 
else 

exp_p_sub(lvl,  pi,  pll); 

end  if; 

when  rparenthl  => 

if  plO  /=  symbol_table(pl).param_end  then 
debug.error(198,  symbols’pos(idl)): 
end  if; 

when  others  =>  debug.error(197,  symbols’pos(idl)) 
end  case; 
end; 

procedure  p_call_tail(lvl,  pi:  integer)  is 

tptl,  pll,  pl2:  integer; 

begin 

case  sym  is 
when  Iparenthl  => 

if  symbol_table(pl).param_end  <=  pi  then 
debug.error(179,symbols’pos(idl)); 

nextsym; 
pll  :=  pi  +  l; 
exp_p_sub(ivl,pl,pll ); 
checksym(  rparenth  1 ,  182); 


when  semicolon  1  => 

if  pi  j—  symbol_table(pl),param  __end  then 
debug. error(  188.  symbols’pos(idl)); 
end  if; 

when  others  =>  debug. error(  187,  symbols’pos(idl)); 
end  case; 
end; 

procedure  proc_cail_stat(lvl,  pi:  integer)  is 
begin 

--pi  points  to  symbol  table  entyr  for  id 
—which  is  a  proc  id 
nextsym; 

p _ call _ ta.il(lvl,  pi); 

end; 

procedure  assign_stat(lvl,  pi:  integer)  is 

typl,  typ2:  integer; 

begin 

vbl  1  ( l vl ,  pi,  typl); 
chev.ksym(becomesl,  97); 
expression(lvl,typ‘2); 
if  typl  /=  typ2  then 
debug. error(  98, symbols’pos(idl)); 
end  if; 
end; 

procedure  pk_stat_tail(lvl,  pi:  integer)  is 
pH:  integer; 
begi  n 

--  now  seeking  id  in  package  located  at  pi 
if  sym  —  id  I  then 

one_sect_check(secondsyrn,pl,pl  1 ); 
if  pll  j-  0  then 
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case  symbol_tabIe(pll).kind  is 
when  proc_id4  =>  proc_call_stat(lvi,  pi  1 ) ; 
when  obj4  |  param4  =>  assign_stat(lvl,  pi  1 ) ; 

when  others  =>  debug. error(94,  symbols'pos(packl)); 
end  case; 
else 

debug.error(95,symbols’pos(packl)); 
end  if; 
else 

debug.error(96,symbols’pos(packl )); 
end  if; 
end; 


procedure  pk_stat(lvl,  pi:  integer)  is 
begin 

—  pi  is  the  address  of  the  pack  def 
if  sym  =  idl  then 
nextsym; 
else 

debug.error(115,  symbols’pos(idl)); 
end  if; 

checksym(dotl,93); 
pk_stat_tail(lvl,  pi); 
end; 

procedure  read_stat(lvl:  integer)  is 

tpt:  integer; 

begin 

nextsym; 

check3ym(lparenth  1,  306); 
vbl(lvl,  tpt); 

if  (tpt  I—  int_pt)  and  (tpt  /=  bool  pt)  then 
debug. error(309,  symbols’pos(id  I)); 
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end  if; 

checksym(rparenthl,  320); 
end; 

procedure  vv_tail(lvl:  integer)  is 

L  J  ’’  i  •  > '  *'  V ‘  '  '  ‘ 

begin 

case  sym  is 

when  coionl  =>  nextsym; 
expression(lvl,  tpt); 
if  tpt  j  —  int_pt  then 
debug. error(305,  sy mbols’pos(id  1 )); 
end  if; 

when  rparenthl  =>  null; 

when  others  =>  debug. error( 304,  symbols’pos(idl)); 
end  case; 
end; 

procedure  write_body(lv]:  integer)  is 

tpt:  integer; 

begin 

checksym(lparenthl,  301); 
expression(IvI,  tpt); 

if  (tpt  /=  int_pt)  and  (tpt  j—  bool_pt)  then 
debug. error(302,  symbols’pos(idl)); 
end  if; 
w__tail(lvl); 

checksym(rparenth  1,303); 
end; 

procedure  write_stat(lvl:  integer)  is 
begin 

case  sym  is 
when  writel  —  > 
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nextsym; 
write_body(lvl); 
when  writelnl  =  > 
nextsym; 

wnen  others  =>  null; 
end  case; 
end; 

procedure  simp_stat(lvl:  integer)  is 

pi,  pll,  pl2:  integer; 

begin 

case  sym  is 

when  nulll  =>  checksym(nulll,901); 
when  idl  =  > 

pi  :=  id_index(secondsym,lvl); 
case  symbol_table(pl).kind  is 
when  proc_id4  =>  proc_ca!l_stat(lvl,  pi); 
when  obj4  |  param4  =>  assign_stat(lvl,  pi); 
when  pkg_id4  => 

pi  :=  symbol_table(pl).pk_pt;  --  make  sure  it  points  to 
—  pack  def 
pk_stat(lvl,pl); 

when  others  =>  debug.error(91,symbols’pos(idl)); 
end  case; 

when  semicolonl  — >  null; 

when  writel  |  writelnl  =>  write_stat(lvl); 

when  readl  =>  read_stat(lvl); 

when  others  =>  debug.error(92,symbols’pos(idl)); 
end  case; 
end; 

procedure  stat_seq(Jvl:  integer); 
procedure  sing_elsif_part(!vl:  integer)  is 
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tpt:  integer; 
begin 

checksym(elsifl,  331); 
expression(lvl,  tpt); 
if  tpt  j—  bool  _pt  then 
debug. error(  151, symbols’pos(elsifl )); 
end  if; 

checksym(then  1,152): 
stat_seq(lvl); 

end; 

procedure  elsif_part(lvl:  integer)  is 
begin 

case  sym  is 
when  e'sifl  => 
sing_elsif_part(lvl); 
elsif_part(lvl); 

when  endl  |  elsel  =>  null; 
when  others  => 

debug.error(330,  symbols’pos(elsifl)); 

end  case; 
end; 

procedure  else_part(lvl:  integer)  is 
begin 

case  sym  is 
when  elsel  => 
nextsym; 
stat_seq(lvl); 

when  endl  =  >  null; 

when  others  =>  debug.error(154,  symbols’p°s(elsel )); 
end  case; 
end; 
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procedure  if_stat(lvl:  integer)  is 

tpt:  integer; 

begin 

checksym(ifl  ,145); 
expression(lvl,  tpt); 
if  tpt  /=  bool_pt  then 
debug.error(146,  symbols’pos(ifl)); 
end  if; 

checksym(thenl,  1451); 
stat_seq(lvl); 
elsif_part(lvl); 
else_part(lvl); 
checksym(end  1,147); 
checksym(ifl,148); 
end; 

procedure  lstat_seq(lvl;  integer); 

procedure  loop_stat(lvl:  integer)  is 
begin 

checksym(loopl,133); 
lstat_seq(lvl); 
checksym(endl,134); 
checksy  m(loopl  ,135); 
end; 

procedure  while_stat(lvl:  integer)  is 

tpt:  integer; 

begin 

checksy  m(  while  1,1 37); 
expression(lvl,  tpt); 
if  tpt  /=  bool_pt  then 
debug,error(138,  symbols’pos(booll)); 
end  if; 
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loop_stat(lvl); 

end; 

procedure  comp_stat(lvl:  integer)  is 
begin 

case  sym  is 

when  if  1  =>  if_stat(lvl); 
when  loopl  =>  loop_stat(ivl); 
when  whilel  =>  while_stat(lvl); 
when  others  =>  debug. error(  106,  symbols’pos(idl)); 
end  case; 
end; 

procedure  statement(lvl:  integer)  is 
begin 

case  sym  is 

when  idl  j  nulil  |  writel  |  writelnl  |  readl  => 
simp_stat(lvl);  checksemi(200); 

when  ifl  |  loopl  |  whilel  =>  comp_stat(lvl);  checksemi(201); 
when  exitl  =>  debug.error(400,  symbols’pos(exitl)); 
when  others  =>  debug.error(90,  symbols’pos(ifl)); 
end  case; 
end; 

procedure  lstatement(lvl:  integer)  is 
begin 

case  sym  is 

when  idl  j  nulil  |  writel  |  writelnl  j  readl  | 
ifl  I  loopl  j  whilel  =>  statement(lvl); 

when  exitl  =>  exit_stat(lvl);  checksemi(401 ); 
when  others  =>  debug. error(402,  symbols’pos(ifl)); 
end  case; 
end; 


page  88 


procedure  stat_seq_tail(lv!:  integer)  is 
begin 

case  sym  is 

when  id  1  |  nulll  |  ifl  |  loopl  |  whilel  | 
writel  |  writelnl  |  readl  => 
statement(lvl); 
stat_seq_tail(lvl); 
when  endl  |  elsifl  |  elsel  =>  null; 
when  exitl  =>  debug. error(403,  symbols’pos(exitl)); 
when  others  => 

debug.error(85,  symbols’pos(idl)); 
end  case; 
end; 

procedure  lstat_seq_tail(lvl:  integer)  is 
begin 

case  sym  is 

when  idl  |  nulll  |  ifl  |  exitl  |  loopl  |  whilel  | 
writel  |  writelnl  |  readl  => 
lstatement(lvl); 
lstat_seq_tail(lvl); 
when  endl  =>  null; 
when  others  => 

debug.error(411,  symbols’pos(id  1)); 
end  case; 
end; 

procedure  stat_seq(lvl:  integer)  is 
begin 

statement(ivl); 
stat_i.  ;q_tail(ivl); 
end; 

procedure  lstat_seq(lvl:  integer)  is 
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begin 

Istatement(lvl); 

lstat_seq_tail(lvl); 

end; 

procedure  decl_part(lvl;  integer); 

procedure  subprog_part(lvI:  integer)  is 
begin 

Pkg_d_pt  :=  pkg_d_pt  +  1; 
pkg_d_stack(pkg_d_  pt)  :=  0; 
decl_part(lvl); 

if  pkg_d_stack(pkg_d_pt)  /=  0  then 
debug.error(112,  symbols’pos(packl)); 
else 

Pkg_d_pt  :=  Pkg_d_pt  -  1; 
end  if; 

checksym(beginl,50); 
stat_seq(lvl); 
checksy m(end  1 ,  51); 
end; 

procedure  subprog_decl(lvl:  integer)  is 

tp,  backlnk:  integer; 

begin 

subprog_header(lvl); 
checksym(isl,  30); 
subprog_part(lvl  +  1); 
checksemi(31); 
end; 

procedure  pkg_d_dec!(ivl:  integer)  is 
begin 

case  sym  is 
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when  id  1  =>  object_decl(lvl);  pkg_d_decl(ivl); 
when  typel  =>  type_decl(lvl);  pkg_d_decl(lvl); 
when  prod  =>  subprog_header(Ivl);  checksemi(64); 

pkg_d_decl(lvl); 
when  endl  =>  null; 

when  others  =>  debug.error(75,  symbols’pos(packl)); 
end  case; 
end; 

procedure  pkg_def_decl(lvl:  integer)  is 
begin 

pkg_d_stack(pkg_d_pt)  :=  pkg_d_stack(pkg_d_pt)  +  1; 

pkg_d_decl(lvl); 

checksym(endl,61); 

checksym(packl,62); 

checksemi(63); 

end; 

procedure  pkg_b_decl(lvl:integer)  is 
begin 

case  sym  is 

when  idl  =>  object_decl(lvl);  pkg_b_decl(lvl); 
when  typel  =>  type_decl(lvl);  pkg_b_decl(lvl); 
when  prod  =>  subprog_decl(lvl); 

pkg_b_decl(lvl); 
when  endl  =>  null; 

when  others  =>  debug. error(74,  symbols’pos(packl)); 
end  case; 
end; 

procedure  pkg_body_decl(lvl:  integer)  is 
begin 

pkg_d_stack(pkg_d_pt)  :=  pkg_d_stack(pkg_d_pt)  -  1; 
pkg _ b _ decl(l  vd); 
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checksym(endl,70); 

checksym(packl,71); 

checksemi(72); 

end; 

procedure  package_decl(lvi:  integer); 

function  proc_check(psnl,  psn2:  integer)  return  boolean  is 
j,  szl,  sz2:  integer;  ok:  boolean; 

—  this  procedure  checks  to  see  that  the  proc  header 

—  declarations  in  pack  def  and  pack  body  are  the  same 
begin 

if  symbol_table(psn2).kind  /=  proc_id4  then 
debug.error(8G,  symbols’pos(packl)); 
return(false); 

elsif  symbol_table(psnl).id_name  /— 
symbol_table(psn2).id__name  then 
debug.error(77,  symbols’pos(packl)); 
return(false); 
else 

szl  :=  symbol  _table(psnl).param_end  -  psnl; 
sz2  :=  symbol_table(psn2).param_end  -  psn2; 
if  szl  j—  sz2  then 

debug.error(78,  symbols’pos(packl)); 
return(false); 
elsif  szl  /=  0  then 

j  :=  1; 

ok  :=  true; 
loop 

ok  :=  symbol_tabIe{psnl+j)-id_name  = 
symbol_table(psn2+j).id__name; 
if  ok  then  ok  :=  symbol_table(psnl+j).kind  =  param4; 
end  if; 

if  ok  then  ok  :=  symbol_table(psn2+j).kind  =  param4; 
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end  if; 

if  ok  then  ok  symbol_table(psnl+j).typ_point  = 
symbol_table(psn2+j).typ_  point; 

end  if; 

if  ok  then  ok  :=  symbol_table(psnl+j).trans  — 
symbol_table(psn2-f-j).trans; 

end  if; 

if  not  ok  then  debug. error(79,symbols’pos(packl)); 
end  if; 
if  ok  then 

j  :=  j  +  1; 

ok  :=  j  <=  szl; 
end  if; 

exit  when  not  ok; 
end  loop; 
end  if; 

return(j  >  szl); 
end  if; 
end; 

procedure  pkg_search(pp,tp:  integer)  is 
ptl,  pt2,  pt3,  nra,  temp:  integer;  ok:  boolean; 
begin 

--  this  procedure  checks  to  see  that  the  proc  headers  in  pack  def 
--  appear  in  pack  body  for  the  same  pack  id. 

—  pp  points  to  pack  def,  tp  points  to  pack  body 
ptl  :=  symbol_table(pp).sect_end; 
pt2  :=  symbol__table(tp).sect_end; 
temp  :=  symbol_table(tp).bkwrd; 
symbol__table(tp).bkwrd  :  =  0; 
while  ptl  j—  pp  loop 

if  symbol_table(ptl),kind  =  proc_id4  then 
nm  :=  symbol_table(ptl).id_name; 
pt3  pt2; 
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symbol_table(U).id_name  :=  nm; 
while  symbol_table(pt3).id_name  /=  nm  loop 
pt3  :=  symbol_table(pt3).bkwrd; 
end  loop; 
if  pt3  =  0  then 

debug. error(  1 10,symbols’pos(procl )); 
elsif  not  proc_check(ptl,pt3)  then 
debug.error(  111  ,symbols’pos(  procl )); 
end  if; 
end  if; 

ptl  :=  symbol_table(ptl).bkwrd; 
end  loop; 

symbol_table(tp).bkwrd  :=  temp; 
end; 

procedure  pkg_tail(lvl;  integer)  is 

pi,  j,  tp,  pp:  integer; 

begin 

case  sym  is 
when  idl  => 

check_new_id(2,  secondsym,  Ivl,  pi); 
if  pi  =  0  then 

enter_var(secondsym,  Ivl,  pkg_id4); 
symbol_table(table_pt).typ  :=  pkg_def3; 
display(lvl-f  1)  tab!e_pt; 
symbol_table(table_pt).sect_end  :=  table_pt; 
symbol_table(table_pt).pk_pt  :=  table_pt; 
else  debug.error(53,symbols’pos(packl));  end  if; 
nextsym; 
checksym(isl,54); 
pkg_def_decl(lvl-f-l); 
when  bodyl  => 
nextsym; 
if  sym  —  idl  then 
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check_new_id(2,  secondsym,  lvl,  pi); 
if  pi  >  0  then 

if  symbol_tabie(pl).typ  /=  pkg_def3  then 
debug.error(59,  symbols’pos(pack  l ) ); 
else 

enter_var(secondsym,  lvl,  pkg_id4); 
tp  :=  tablc_pt; 

symbol_table(tab!e_pt).typ  :=  pkg_bdy3; 
symbol_table(tab!e_pt).pk_pt  :=  pi; 

pp  :=  pi; 

display(lvl-i-l)  :=  table_pt; 

symbol_table(table_pt).sect_end  table_pt: 
end  if; 
else 

debug.  error(60,symbols’pos(  pack  1 )); 
end  if; 
nextsyrn; 
else 

debug.error(61,  syrnbols’pos(idl)); 
end  if; 

checksym(isl,56); 
pkg_body_decl(lvl+l); 
pkg__search(pp,  tp); 

--end  when  bodyl 

when  others  =>  debug.error(61,symbo!s’pos(packl)); 
end  case; 
end; 

procedure  package_decl(lvl:  integer)  is 
begin 

checksym(packl,  52); 
pkg_tail(lvl); 
end; 
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procedure  dedaration(lvkinteger)  is 
begin 

case  sym  is 

when  idl  =>  object_decl(lvl); 
when  typel  =>  type_decl(lvl); 
when  prod  =>  subprog_decl(!vl); 
when  packl  =>  package_decl(Ivl); 
when  others  =>  debug. error(2,  symbols’pos(syni)); 
end  case; 
end; 


procedure  decl_part(lvl:  integer)  is 
begin 

if  sym  =  typel  or  sym  =  idl  or  sym  =  prod  or  sym  =  packl  then 
declaration(lvl); 
decl_part(lvl); 
elsif  sym  /=  begin  1  then 
debug.error(52,  symbols’pos(procl)); 
end  if; 
end; 


procedure  program  is 
begin 

subprog_decl(-l); 

end; 


begin 
getfile; 
n  ext  sym; 
program; 

show__table; 

exception 

when  text_io.name_error  => 
text_io.put_line(”File  4outl’  not  found”); 
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when  err_excep  => 
text_io,put_line("  Error”); 
end  pass2; 
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4.  Pass3:  Code  Generation. 


This  pass  generates  code  for  a  stack  machine,  namely  the  a-machine  implemented 
in  pass4.  The  code  it  produces  is  not  very  efficient  however  this  could  be  overcome  with  an 
additional  optimization  pass.  This  could  be  a  project  in  a  more  advanced  course.  The  code 
produced  for  the  following  factorial  program  is  shown  below  in  mnemonic  form.  The  actual 
code  is  produced  on  a  file  called  CODE  and  is  coded  into  integers. 

proc  tst20  is 
x:  int; 

proc  fact(n:  int;  ans:  out  int)  is 

k:  int; 

begin 

if  n  <=  1  then  ans  :=  1; 
else 

fact(n  -  1,  k); 
ans  :=  n  *  k; 
end  if; 
end; 
begin 
fact(5,  x); 
write(x:5); 
end; 

Code: 

j.  :  m  bl3  0 

2:  cal3  0  30  4 

3:  hlt3 

4:  fad3  1  3 

5:  lod3 

6:  1  i 1 3  1 

7:  le3 
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8:  jz3  13 

9:  lai3  1  4 

10:  lit3  1 

11:  sto3 
12:  jmp3  29 

13:  mbl3  5 

14:  lad3  1  3 

15:  lod3 
16:  lit3  1 

17:  iub3 

18:  blmd3  3  1 

19:  lad3  1  5 

20:  blmd3  4  1 

21:  cal3  1  4  6 

22:  lai3  1  4 

23:  lad3  1  3 

24:  lod3 

25:  lad3  1  5 

26:  lod3 

27:  muI3 

28:  sto3 

29:  ret3  1 

30:  mb!3  5 

31:  lit3  5 

32:  blmd3  3  1 

33:  lad 3  0  3 

34:  blmd3  4  1 

35:  cal3  1  4  6 

36:  Iad3  0  3 

37:  lod3 

38:  lit3  5 

39:  wrti3  1 

40:  ret3  0 

41:  endm3 
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We  now  present  pass3: 


with  text_io; 

package  int_io  is  new  text_io.integer_io(integer); 
with  text_io;  with  int_io; 
procedure  pass3  is 
symtop:  constant  :=  500; 

type  symbols  is  (beginl,  endl,  dotl,  elsifl,  becomesl,  plusopl,  —5 
minusopl,idl,  intlitl,  lparenthl,  rparenthl,  —10 
semicolonl,  commal,  endtextl,  outl,  ifl,  —15 
thenl,  loopl,  exitl,  linenol,  errorl.  It  1 ,  lei,  —22 
gtl,  gel,  eql,  nel  ,  starl,  slashl,  andl,  —29 
orl,  notl,  colonl,  inti,  booll,  arrayl,  —35 
bodyl,  charl,  dotdotl,  isl,  typel,  truel,  falsel,— 42 
elsel,  ofl,  modi,  nulll,  packl,  recordl,  -48 
whenl,  whilel,  procl,  ini,  writel,  writelnl,  readl);  -55 


type  typekind  is  (int3,  bool3,  char3,  array3,  rec3,  proc3,  pkg_def3, 
pkg_bdy3,  notyp3); 

type  idkind  is  (obj4,  typ_id4,  param4,  proc_id4,  pkg_id4,  unknown_id4); 

type  operation  is  (add3,  and3,  bid 3 ,  blmd3,  blmi3,  cal3,  div3,  —6 
endm3,  eq3,  —.8 

ge3,  gt3,  hlt3,  jmp3,  jnz3,  jz3,  lad3,-15 
lai3,  le3,  lit3,  lod3,  lt3,  mbl3,  mod3,-22 
mul3,  ne3,  neg3,  nop3,  not3,  or3,  rdb3,  rdi3,  -30 
ret3,  sto3,  sub3,  wrtb3,  wrti3);  —35 

op_sing,  op_doub,  op_trip:  array  (operation)  of  boolean  := 

(add3  ..  wrti3  =>  false); 

int_pt,  bool_pt,  char__pt:  integer; 
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type  modekind  is  (in5,  out5); 


infill,  fout2,  lisi-file,  mnfile,  codefi,  codemn:  text_io.file_type; 
sym:  symbols; 

i,  linenum,  secondsym,  errposn  :  integer; 
endfile:  boolean; 

type  item  is  record 

bkwrd,  lvl,  dsp,  pdsp,  size,  lo:  integer; 
id_name:  integer; 
kind:  idkind; 

typ:  typekind; 
trans:  modekind; 
nrml:  boolean; 

typ_point,  pk_pt  integer; 
param_end,  sect_end:  integer; 
end  record; 

symbol_table:  array(0  ..  symtop)  of  item; 

double,  invisible:  array(symbols)  of  boolean  :=  (beginl  ..  readl  =>  false); 
levmax:  constant  :=  25; 

display:  array(integer  range  -1  ..  levmax)  of  integer; 

subtype  strll  is  string(l  ..  11); 
subtype  str20  is  string(l  ..  20); 
subtype  str7  is  string(l  ..  7); 
subtype  str8  is  string(l  ..  8); 
err_excep.  coderr:  exception; 
table_pt:  integer; 

pkg_d_stack:  array(l  ..  100)  of  integer; 
pkg_d_pt:  integer; 
type  order  is  record 
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oprtn,  opndl,  opnd2,  opnd3:  integer; 
end  record; 

codelim:  constant—  500; 
code:  array(l  ..  codelim)  of  order; 
codept:  integer  :=  0; 
dispconst:  constant  :=  3; 

package  debug  is 
type  oprek  is  record 
opnm:str7; 
oplen:integer; 
end  record; 

opmnem:  array(operation)  of  oprek; 
tmnem:  array(typekind)  of  str8; 
procedure  emit(n:  integer); 
function  size(n:  integer)  return  integer; 
function  length(st:  strll)  return  integer; 
procedure  emitl(k,n:  integer); 
procedure  emit2(m,n:integer); 
procedure  error(m,k:  integer); 
end  debug; 

package  body  debug  is 
endmntable:  constant  :=  55; 
outlen,  mnemlen:  integer; 

mnem:  array(integer  range  0.. endmntable)  of  strll; 

function  size(n:  integer)  return  integer  is 
neg:  boolean;  nn,  len:  integer; 
begin 
nn  :  =  n; 

neg  :=  (nn  <  0); 

if  neg  then  nn  :=  -nn;  end  if; 

if  nn  <=  9  then  len  :=  1; 
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elsif  nn  <=99  then  len  :=  2; 
elsif  nn  <=  999  then  len  :=  3; 
elsif  nn  <=  9999  then  len  :=  4; 
elsif  nn  <=  32767  then  len  :=  5; 
end  if; 

if  neg  then  return  len  +  1; 
else  return  len;  end  if; 
end  size; 

procedure  emit(n:  integer)  is 

sz:  integer; 

begin 

sz  :=  size(n); 

text_io.put(fout2,’  ’);  int_io.put(fout2,n,  sz); 
outlen  :=  outlen  +  sz  -f  1; 
if  outlen  >=72  then 
text_io.new_line(fout2); 
outlen  :=  0; 
end  if  ; 
end  emit; 

function  length(st:  stril)  return  integer  is 
i:  integer; 
begin 
i  ;=  11; 

while  st(i)  =  ’  ’  loop 
i  :=  i  -  1; 
end  loop; 
return  i; 
end; 

procedure  emitl(k,n:  integer)  is 

Ingth,  sz:  integer; 

begin 
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if  k  =  1  then 

lngth  :=  length(mnem(n)); 
emit(n); 

text_io.put(mnfile,  ’  mnem(n)(l  ..  lngth)); 
mnemlen  :=  mnemlen  +  lngth  +  1; 
if  mnemlen  >=65  then 
text_io.put_line(mnfile,””); 
mnemlen  :=  0; 
end  if; 
else 

emit(n); 
sz  :=  size(n); 

text_io.put(mnfile,’  ’);  int_io.put(mnfi!e,n,sz); 
mnemlen  :=  mnemlen  -f  sz  +  1; 
if  mnemlen  >=  65  then 
text_io.put__line(mnfile,””); 
mnemlen  :=  0; 
end  if; 
end  if; 
end  emitl; 


procedure  emit2(m,n:integer)  is 
begin 

emitl(l,m);  emitl(2,n); 
end; 

procedure  error(m,k:  integer)  is 
begin 

emit2(symbols’pos(errorl),  m); 
errposn  :=  m; 
raise  err_excep; 
end  error; 


> 
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begin  -package  debug  initialization  section 
mnem(O)  :=  ’’beginl 
mnem(l)  :=  ”endl 
mnem(2)  ”dotl 
mnem(3)  :=  ’’elsifl 
mnem(4)  :=  ’’becomesl 
mnem(5)  :=  ’’plusopl 
mnem(d)  :=  ’’minusopl 
mnem(7)  :=  ”idl 
mnem(8)  :=  ”intlitl 
mnem(9)  :=  ’’Iparenthl 
mnem(10)  :=  ”rparenthl 
mnem(ll)  :=  ’’semicolonl 
mnem(12)  :=  "commal 
mnem(13)  :=  "endtextl 
mnem(14)  :=  ”outl 
mnem(15)  :=  ”ifl 
mnem(16)  :=  ”thenl 
mnem(17)  :=  ”loopl 
mnem(18)  :=  ’’exit! 
mnem(19)  :=  "linenol 
mnem(20)  :=  ’’errorl 
mnem(21)  :=  ”ltl 
mne*ri(22)  :=  ”le2 
mnem(23)  :=  ”gtl 
mnem(24)  ”gel 
mnem(25)  :=  ”eql 
mnem(26)  :=  ”nel 
mnem(27)  :=  ”starl 
mnem(28)  :=  ’’slash  1 
nmem(29)  :=  ”andl 
mnem(30)  :=  ”orl 
mnem(31)  :=  ”notl 
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mnem(32)  := 

’’colon  1 

M  . 

» 

maem(33)  := 

”intl 

w . 
y 

mnem(34)  :  = 

WU  |1 

ii  „ 

mnem(35) 

’array  1 

*y  , 

mnem(36)  :  = 

’’body  1 

» 

ninem(37)  :  = 

’’charl 

H  , 

mnem(38)  := 

’’dotdotl 

> 

mnern(39)  :  = 

”  is  1 

mnem(40)  := 

’’typel 

i 

mnem(41)  := 

’’truel 

M 

1 

mnem(42)  :  = 

”  false  1 

V  , 

y 

mnem(43)  := 

’’elsel 

n , 

mnem(44)  := 

”ofl 

if , 

mnem(45)  := 

’’modi 

» , 
y 

mnem(46)  := 

”nuill 

. 

i 

mnem(47)  :  = 

”packl 

?■» . 

mnem(48)  :  = 

” record  1 

yy . 

mnem(49)  :  = 

’’when  1 

yy . 

mnem(50)  := 

’’whilel 

yy . 
y 

mnem(51)  :  = 

”procl 

yy « 

i 

mnem(52)  :  = 

”inl 

Vi  . 

> 

mnem(53)  := 

’’writel 

M 

mnem(54)  :  = 

’’writelnl 

yy . 

mnem(55)  := 

”  read  1 

opmnem  :=  ((”add3 

’’  4) 

(”and3  ” 

4)- 

(”bld3  ”, 

4), 

(”blrnd3  ” 

,  5), 

(”bimi3  ” 

5), 

("cal3  ”, 

4), 

(”div3  ”, 

4), 

(”endm3  ’ 

\5), 

(”eq3  ”, 

3), 
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(”ge3  ”,  3), 

(”gt3  ",  3), 

(”hlt3  ”,  4), 

(”jmp3  ”,  4), 

(”jnz3  ”,  4), 

(”jz3  ”,  3), 

(”lad3  ”,  4), 

(”lai3  ”,  4), 

(”le3  ”,  3), 

(”iit3  ”,  4), 

(”lod3  ”,  4), 

(”lt3  ”,  3), 

("*mbl3  ”,  4), 

(”mod3  ”,  5), 

(”mul3  ”,  4), 

(”ne3  ”,  3), 

(”neg3  ”,  4), 

(” noP3  ”,  4), 

(”not3  ”,  4), 

(”°r3  ”,  3), 

(”rdb3  ”,  4), 

(”rdi3  ”,  4), 

(”ret3  ”,  4), 

(”sto3  ”,  4), 

(”sub3  ”,  4), 

(”wrtb3  ”,  5), 

(”wrti3  ”,  5)); 

tmnem  :=  (”int3  ”,  ”boo!3  ”,  ”char3  ”, 
”array3  ”,  ”rec3  ”,  ”proc3  ”,  ”pkg  _def3”, 
”pkg_bdy3”,  ”notyp3  ”); 

outlen  :=  0;  mnemlen  :=  0; 
end  debug; 
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package  initialize  is 
procedure  init; 
end  initialize; 

package  body  initialize  is 
procedure  init  is 
begin 

double(idl)  :=  true; 
double(intlitl )  :=  true; 
double(iinenol)  :=  true; 
double(errorl)  :=  true; 
invisible(linenol)  :  =  true; 
invisible(erroi  l)  :=  true; 
PkS_d_Pt  :=  0; 
op_sing(lit3)  :=  true; 
op_sing(mbl3)  :=  true; 
op_sing(jmp3)  :=  true; 
op_sing(jnz3)  :=  true; 
op_sing(jz3)  :=  true; 
op_sing(wrti3)  :=  true; 
op_sing(wrtb3)  :  =  true; 
op_trip(cal3)  :=  true; 
op_doub(lad3)  :=  true; 
op_doub(lai3)  :=  true; 
op_sing(bld3)  :=  true; 
op_doub(blmd3)  :=  true; 
op_doub(bImi3)  :=  true; 
op_sing(ret3)  :=  true; 
end  init; 
begin 
init; 

end  initialize; 

procedure  coder0(oprt:  operation)  is 
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begin 

codept  :=  codept  +  1; 
if  codept  >  codelim  then 
raise  coderr; 
end  if; 

code(codept).oprtn  :=  operation’pos(oprt); 
end; 

procedure  coderl(oprt:  operation;  opd:  integer)  is 
begin 

codept  :=  codept  +  1; 
if  codept  >  codelim  then 
raise  coderr; 
end  if; 

code(codept).oprtn  :=  operation’pos(oprt); 
code(codept).opndl  :=  opd; 
end; 

procedure  coder2(oprt:  operation;  opdl,  opd2:  integer)  is 
begin 

codept  :=  codept  -f  1; 
if  codept  >  codelim  then 
raise  coderr; 
end  if; 

code(codept).oprtn  :=  operation’pos(oprt); 
code( codept). opndl  :=  opdl; 
code(codept),opnd2  :=  opd2; 
end; 

procedure  coder3(oprt:  operation;  opdl,  opd2,  opd3:  integer)  is 
begin 

codept  :=  codept  -f  1; 
if  codept  >  codelim  then 
raise  coderr; 
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end  if; 

code(codept),oprtn  :=  operation’pos(oprt); 
code(codept).opndl  :=  opdl; 
code(codept).opnd2  :=  opd‘2; 
code(codept).opnd3  :=  opd3; 
end; 

procedure  s how _ ops  is 
op:  operation; 
begin 

for  i  in  1  ..  codept  loop 
int_io.put(i,4);text_io.put(”:  ”); 
op  operation’val(code(i).oprtn); 
text_io.put(debug.opmnem(op).opnm); 
if  op_sing(op)  then 
int_io.put(code(i).opndl,6); 
elsif  op_doub(op)  then 
int_io.put(code(i).opndl,6); 
int_io.put(code(i).opnd2,6); 
elsif  op_trip(op)  then 
int_io.put(code(i).opndl,6); 
int_io.put(code(i).opnd2,6); 
int_io.put(code(i).opnd3,6); 
end  if; 

text  _io.new_  line; 
end  loop; 

text_io.put(”codept  =  ”); 
int_io.put(codept); 

text  __io.  new _ line; 

end; 

procedure  get  file  is 
use  text_io; 
begin 
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open(infil,in_file,”outl”); 
create(listfile,out_file, ’’lister”); 
create(fout2,out_file,”out2”); 

--  The  file  mnem2  is  used  for  debugging  purposes. 
--  It  can  be  eliminated  later. 
create(mnfile,  out_fiie,  ”mnem2”); 
text_io.put_line(mnfile,”pass3.ada  mnem2”); 
text_io.new_line(mnfiIe); 
create(codefi,  text_io.out_file,  ’’code”); 
end; 


procedure  nextsym  is 
firstsym:  integer; 
use  int_io; 
begin 

get(infil,  firstsym); 
sym  :=  symbols’val(firstsym); 
while  invisible(sym)  loop 
debug.emitl(l, firstsym); 
get(infil,  secondsym); 
debug. emitl(2,  secondsym); 
if  sym  =  linenol  then 
linenum  :=  secondsym; 
elsif  sym  =  errorl  then 
debug.error(l,  secondsym); 
end  if; 

get(infil,  firstsym); 
sym  ;=  symbols’val(firstsym); 
end  loop; 

debug.emitl(l,firstsym); 
if  double(sym)  then 
get(infil,  secondsym); 
debug. emitl(2,  secondsym); 


page  1 1 1 


end  if; 

end  nextsym; 
package  b  entry  is 

procedure  basic_entry(id,tpt:  integer; 

knd:idkind;  tp:typekind); 

end  b_entry; 

package  body  b_entry  is 
procedure  basic_entry(id,tpt:  integer; 

knd:idkind;  tp:typekind)  is 

begin 

table_pt  :=  table_pt  +  1; 

symbol_table(table_pt).bkwrd  :=  table__pt  -  1; 
symbol_table(table_pt).id_name  :=  id; 
symbol_table(table_pt).lvl  :=  -1; 
symbol_table(table_pt).kind  :=  knd; 
symbol__table(table_pt).typ  :=  tp; 
symbol__table(tabIe_pt).typ_ point  :=  tpt; 
end; 

begin  —  b_entry 
table_pt  :=  0;  display(-l)  :=  1; 
basic_entry(-l,  -1,  proc_id4,  proc3); 
basic_entry(symbols’pos(intl),  -1,  typ_id4,  int3); 
int_pt  :=  table_pt; 
symboi_table(table_pt).size  :=  1; 

basic_entry(symbols’pos(booll),  -1,  typ_id4,  boo!3); 
bool_pt  :=  table_pt; 
symbol_table(table_pt).size  :=  1; 

basic_entry(symbols’pos(charl),  -1,  t.yp_id4,  char3); 
char_pt  :=  table_pt; 
symbol_table(table_pt).size  :=  1; 
symbol_table(l).sect_end  :=  table_pt; 
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procedure  checksym(symb:  symbols;  n:  integer)  is 
begin 

if  sym  —  symb  then  nextsym; 
else  debug. error(n,symbols’pos(sym));  end  if; 
end; 

procedure  checksemi(n:  integer)  is 
begin 

checksym(semicolonl,n); 

end; 

procedure  show_table  is 
begin 

text_io.put(”  inx  name  type  typpt  bwrd  sctnd’’); 
text_io.put_line(”  dsp  size  lvl  lo” ); 
for  i  in  1  ..  table_pt  loop 
int_io.put(i,3); 

int_io.put(symbol_table(i).id__name,9); 
text_io.put(”  ”); 

text_io.put(debug.tmnem(symbol_table(i).typ)); 
int_io.put(symbol_tabie(i).typ_point,7); 
int_io.put(symbol_table(i).bkwrd,7); 
int_io.put(symbol_table(i).sect_end,7); 
int_io.put(symbol_table(i).dsp,8); 
int_io.put(symbol_table(i).size,8); 
int_io.put(symbol_tabIe(i).lvl,9); 
int_io.put(symbol_table(i).Io,7); 
text_io.nevv_line; 
end  loop; 
end; 


procedure  show_table2  is 


begin 

text_io.put(”  inx  name  type  pdsp  bwrd  sctnd"); 
text_io.put_line('’  dsp  size  lvl  lo”); 
for  i  in  1  ..  table_pt  loop 
int_io.put(i,3); 

int_io.put(symbol_table(i).id_name,9); 
text_io.put(”  ”); 

text_io.put(debug.tmnem(symbol_table(i).typ)); 
int_io.put(symbol_table(i).pdsp,7); 
int_io.put(symbol_table(i).bkwrd,7); 
int_io.put(symbol_table(i).sect_end,7); 
int_io.put(symbol_table(i).dsp,8); 
int_io.put(symbol_table(i).size,8); 
int_io.put(symbol_table(i).lvl,9); 
int_io.put(symbol_table(i).lo,7); 
text_io.new_line; 
end  loop; 
end; 


procedure  enter_var(iden,  lv,  plvl:  integer;  knd:  idkind)  is 

j,  k:  integer; 

begin 

table_pt  :=  table_pt  +  1; 
symbol_table(tab!e_pt).bkwrd  := 

symbo!_table(display(lv)).sect_end; 
symbol_table(table_pt).id_name  :=  iden; 
symbol_table(table_pt).lvl  :=  plvl; 
symbol_table(table_pt).kind  :=  knd; 
symbol_table(table_pt).typ  :=  notyp3; 
symbol__table(tabIe_pt).nrml  :=  true; 
symboI_table(display(lv)).sect_end  :  =  table_pt; 
symbol_table(table_pt).pk_pt  :=  -1; 
end; 
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procedure  one_sect_check(ss,tp:  integer;  pi:  out  integer)  is 
temp,  j:  integer; 

—  checks  a  section  for  an  id 
begin 

temp  :=  symbol_table(tp).bkwrd; 
symbol_table(tp).bkwrd  :=  0; 
symbol_table(0).id_name  :=  ss; 
j  :=  symbol_tab]e(tp).sect_end; 
while  symbol_table(j).id_name  /=  ss  loop 
j  :=  symbol_table(j).bkwrd; 
end  loop; 

symbol_table(tp).bkwrd  :=  temp; 
pi  :=  j; 
end; 


procedure  check_new_id(n,  ss,  lvl:  integer;  pi  :  out  integer)  is 

temp,  j,  k,  pp,  tp:  integer; 

begin 

tp  :=  display(Ivl); 
symbol_table(0).id_name  :=  ss; 
one_sect_check(ss,tp  j); 

—  If  the  section  is  a  pack  body  then  special  conditions  prevail. 

—  For  object  variables  and  type  variables  check_new_id  should  consider 

—  the  pack  def  as  part  of  the  search  domain.  In  the  case  of  procedures 

—  however  check_new_id  should  only  search  within  the  pack  body.  A  second 

—  check  later  will  verify  that  the  pack  def  procedures  have  a  body, 
if  n  =  1  then 

if  (j  =  0)  and  (symbol_table(tp).typ  =  pkg_bdy3)  then 
pp  :=  symbol__table(display(lvl)).pk_pt; 
one_sect_check(ss,  pp,  k); 
end  if; 
end  if; 
pl  :=  j; 
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end; 

function  id_index(id,  lvl:  integer)  return  integer  is 

lv,  Ink,  temp,  tp,  pp:  integer; 

begin 

lv  :=  lvl;  symbol_table(Q).id_name  :=  id; 
loop 

tp  —  display(lv); 
one_sect_check(id,tp,Ink); 

if  (Ink  =  0)  and  (symbol_table(tp).typ  =  pkg_bdy3)  then 
pp  :=  symbol_table(tp).pk_pt; 
one_sect_check(id,pp,lnk); 
end  if; 
lv  :=  lv  -  1; 

exit  when  (lv  <  -  1)  or  (Ink  /=  0); 
end  loop; 
return  ink; 
end; 

procedure  id _ list _ tail(l vl,  plvl:  integer)  is 

place:  integer; 
begin 

if  sym  =  commal  then 
nextsym; 
if  sym  =  id  1  then 

check_new_id(l,  secondsym,lvl,  place); 
if  place  =  0  then  enter_var(secondsym,lvl,plvl,obj4); 
else  debug. error(7,symbols’pos(idl));  end  if; 
nextsym; 

else  debug.error(8,symbols’pos(idl));  end  if; 

id _ list _ tail(lvl,  plvl); 

else 

--  test  follow  symbols  for  id _ list _ tail 

if  sym  /=  colonl  then  debug. error(6,symbols’pos(colonl)); 
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end  if; 
end  if; 
end; 

procedure  id_list(lvl,  plvl:  integer)  is 

place  :  integer; 

begin 

if  sym  =  idl  then 

check_new_id(l,  secondsym,  lvl,  place); 
if  place  =  0  then  enter_var(secondsym, lvl, plvl,  obj4); 
else  debug.error(5,symbols’pos(idl));  end  if; 
nextsym; 

else  debug.error(6,symbols’pos(idl));  end  if; 

id _ list _ tail(lvl,  plvl); 

end; 

procedure  type_ind(lvl:  integer;  tp:  out  integer)  is 

j:  integer; 

begin 

case  sym  is 
when  idl  => 

j:=  id_index(secondsym,  lvl); 
if  j  —  0  then  debug.error(9,symbols’pos(idl)); 
elsif  symbol_table(j).kind  /=  typ_id4  then 
debug. error(  10, symbols’pos(idl)); 
else  tp  :=  j; 
end  if; 
nextsym; 

when  inti  => 
tp  :=  2;  nextsym; 
when  booll  => 
tp  :=  3;  nextsym; 
when  charl  => 
tp  :=  4;  nextsym; 
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when  others  => 

debug.error(ll,symbols’pos(idl)); 

end  case; 
end; 

procedure  fill_type(st,  fin,  tp:  integer;  displ:  in  out  integer)  is 

tt:  typekind;  disp,  sz:  integer; 

begin 

disp  :=  displ; 

tt  :=  symbol_table(tp).typ; 
sz  :=  symbol_table(tp).size; 
for  i  in  st  ..  fin  loop 
symbol_table(i).typ_point  :=  tp; 
symbol_table(i).typ  :=  tt; 
symbol_table(i).dsp  :=  disp; 
symbol_table(i).size  :=  sz; 
if  symbol_tab!e(i).typ  =  array3  then 
symboI_table(i).lo  :=  symbol_table(tp).lo; 
end  if; 

disp  :=  disp  +  sz; 
end  loop; 
displ  :=  disp; 
end; 

procedure  object_decl(ivl,  plvl:  integer;  displ:  in  out  integer)  is 

strt_pt,  end_pt,  tp_pt:  integer; 

begin 

strt_pt  :=  table_pt  +  1; 

id _ list(lvl,  plvl); 

end_pt  table_pt; 
checksym(colonl,  3); 
type_ind(lvl,tp_pt); 
fill_type(strt_pt,  end_pt,  tp_pt,  displ); 
checksemi(4); 
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end; 


procedu  'e  stype_def(lvl:  integer)  is 

se:  integer; 

begin 

se  :=  symbol _tabie(display(lvi)).sect_end; 
case  sym  is 

when  inti  =>  symbol__table(se).typ_point  :=  int_pt; 

symbol_table(se).typ  :=  int3; 
when  booll  :=>  symbol_table(se).typ_point  :=  bool_pt; 

symbol_table(se).typ  :=  bool3; 
when  others  =>  debug. error(17,  symbols’pos(typel)); 
end  case; 
nextsym; 
end; 

procedure  index_bd(val:  out  integer)  is 
begin 

case  sym  is 
when  intlitl  => 
val  :=  secondsym; 
nextsym; 

when  plusopl  => 
nextsym; 

if  sym  =  intlitl  then 
val  :=s  secondsym; 
nextsym; 
else 

debug.error(230,  symbols’pos(intlitl)); 
end  if; 

when  minusopl  => 
nextsym; 

if  sym  =  intlitl  then 
val  :=  -  secondsym; 
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nextsym; 

else 

debug.error(2301,  symbols’pos(intlitl)); 
end  if; 

when  others  => 

debug.error(231,symbols’pos(intlitl)); 

end  case; 
end; 

procedure  index_range(low,  high:  out  integer)  is 
begin 

index_bd(low); 
checksym(dotdotl,  23); 
index_bd(high); 
end; 

procedure  arrav_def(lvl:  integer)  is 

tp,  j,  low,  high:  integer; 

begin 

checksym(arrayl,  18); 
checksym(lparenthl,  19); 
index_range(low,  high); 
symbol_tab!e(table_pt).lo  :=  low; 
checksym(rparenthl,  21); 
checksym(ofl,  20); 
type_ind(lvl,  tp); 

j  :=  symbol_table(display(lvl)).  sect_end; 
symbol_table(j).typ_point  :=:  tp; 
symbol_table(j).typ  :=  array3; 

symbol_table(j),size  :=  (high  *  low  +  1)  *  symbol_table(tp).size 
end; 

procedure  comp_def_tail(lvl,  plvl:  integer;  displ:  in  out  integer)  is 
begin 
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if  sym  =  id  1  then 

object_decl(iv],  pivl,  displ); 
comp_def_tail(lvl,  pivl,  displ); 
elsif  sym  /=  endl  then  --  takes  care  of  follow  symbols 
debug. error(29, sym  bols’pos(id  1)); 
end  if; 
end; 

procedure  comp_def(lvl,  pivl:  integer)  is 

disp:  integer; 

begin 

disp  :=  0; 

object_decl(lvl,  pivl,  disp); 
comp_def_tail(lvl,  pivl,  disp); 
symbol_table(display(lvl)).size  :=  disp; 
end; 


procedure  record _def(lvl,  pivl:  integei)  is 

tp,  disp:  integer; 

begin 

checksym(recordl,  25); 
symbol_table(table_pt).typ  :=  rec3; 
tp  :=  table_pt; 

symbol_table(tp).sect_end  :=  tp; 
symbol_table(tp).typ_ point  :=  tp; 

display(lvl-fl)  •'=  tp; 

comp_def(lvl-fl,  -1); 
checksym(endl,  27); 
checksym(recordl,  28); 

symbol_table(tp),sect_end  :=  table_pt; 
end; 

procedure  type_def(lvl,  pivl:  integer)  is 
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begin 

case  sym  is 

when  inti  |  booll  ]  charl  =>  stype_def(lvl); 
when  arrayl  =>  array _def{lvl); 
when  record  1  =>  record _def(lvl,  plvl); 
when  others  =>  debug. error(16,symbols’pos(typel )); 
end  case; 
end; 

procedure  type_decl(lvl,  plvl:  integer)  is 

pi:  integer; 

begin 

checksym(typel,12); 
if  sym  =  idl  then 

check_new_id(l,  secondsym,M,  pi); 
if  pi  /=  0  then 

debug.  error(  13,  symbols’pos(idl)); 
else 

enter_ var(secondsym,  Ivl,  plvl,  typ_id4); 
end  if; 

symbol_table(tabIe_  pt).dsp  :=  0; 
nextsym; 
else 

debug. error(  14, symbols’pos(idl)); 
end  if; 

checksym(isl,14); 
type_def(lvl,  plvl); 
checksemi(  15); 
end; 

procedure  mode(md:  out  modekind)  is 
begin 

case  sym  is 

when  ini  —  >  rml  :=  in5;  nextsym; 
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when  out  1  =>  md  out5;  nextsym; 

—  deal  with  follow  symbols 
when  idl  |  inti  j  booll  =>  md  :=  in5; 
when  others  =>  debug.error(46,symbols’pos(typel)); 
end  case; 
end; 

procedure  p_tail(lvl,  plvl:  integer)  is 

place:  integer; 

begin 

if  sym  =  cornmal  then 
checksym(commal,40); 
if  sym  =  idl  then 

check_new_id(2,  secondsym,  Ivl,  place); 

if  place  =  0  then  enter_var(secondsym,lvl,  plvl,  param4); 
else  debug. error(41,symbols’pos(idl));  end  if; 
nextsym; 
p _ tail(lvl,  plvl); 

else  debug. error(42, symbols’pos(id  1 ));  end  if; 
elsif  sym  /=  colonl  then 

debug.error(43,  symbols  pos(id  1 )); 
end  if; 
end; 

procedure  sparam_decl(l vl,  plvl:  integer;  disp:  in  out  integer)  is 
strt_pt,  end _pt,  tp,  i:  integer;  tt:typekind; 
md:  modekind;  place,  displ,  sz,  ss:  integer; 
begin 

displ  :=  disp; 
if  sym  =  id  1  then 

check_new_id(2,  secondsym,  Ivl,  place); 
if  place  =  0  then 

strt_pt  :  —  tab!e_pt  +  1; 
enter_var(secondsym, Ivl, plvl,  pararnl); 


page  123 


else  debug.error(37,symbols’pos(idl));  end  if; 
nextsym; 

else  debug. error(38,symbois’pos(idl));  end  if; 
p_tail(lvl,  plvl); 
end_pt  :=  table_pt; 
checksym(colonl,39); 
mode(md); 
type_ind(lvl,  tp); 
tt  :=  symbol_table(tp).typ; 
sz  :=  symbol__table(tp).size; 
for  i  in  strt_pt  ..  end_pt  loop 
symbol_table(i).typ_point  :=  tp; 
symbo!_table(i).typ  :=  tt; 
symbol_table(i).trans  :=  md; 
if  md  =  out5  then 
symbol _table(i).nrml  :=  false; 
ss  :=  1; 
else 

ss  :=  sz; 
end  if; 

symbol_table(i).dsp  :=  displ; 
symbol_table(i).size  :=  ss; 
displ  :=  displ  -f  ss; 
end  loop; 
disp  :=  displ; 
end; 

procedure  p_dec_tail(lvl,  plvl:  integer;  displ:  in  out  integer)  is 
begin 

if  sym  =  semicoioni  then 
checksemi(44); 
sparam_decl(lvl,  plvl,  displ); 
p_dec_tail(lvl,  plvl,  displ); 
elsif  sym  /=  rparenthl  then 
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debug,error(45,  symbols’pos(rparenthl)); 
end  if; 
end; 

procedure  param_deci(lvl,  plvl:  integer;  displ:  in  out  integer)  is 
begin 

sparam_decl(lvl,  plvl,  displ); 

p _ dec _ ta.it(lvl,plvl,  displ); 

end; 

procedure  formal_part(lvl,  plvl:  integer;  displ:  in  out  integer)  is 
begin 

if  sym  =  lparenthl  then 
checksym(lparenthl,35); 
param_decl(lvl,  plvl,  displ); 
checksym(rparenthl,36); 
end  if; 
end; 

procedure  subprog_header(lvl,  plvl:  integer;  disp,  tpt:  out  integer) 

pi,  tp,  displ:  integer; 

begin 

displ  :=  dispconst; 
checksym(procl,32); 
if  sym  =  id  1  then 
tp  :=  table_pt  1; 

enter_var(secondsym,  lvl,  plvl,  proc_id4); 
symbol_table(tp).sect_end  :=  tp; 
symbol_table(tp).param_end  :=  tp; 
symbo!_table(tp).typ  :=  proc3; 
symbol_table(tp).size  :==  -1; 
symbol_table(tp).lo  :=  -1; 
tpt  :=  tp; 
nextsym; 
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end  if; 

display(lvl+l)  :=  tp; 
formal_part(lvl+l,  plvl+1,  displ); 
symbol_table(tp).pdsp  :=  displ; 
disp  :=  displ; 

symbol_table(tp).param_end  := 
symbol_table(tp).sect_end; 
end; 

procedure  expression(lvl,  plvl:  integer;  typ_pt:  out  integer); 

procedure  vbl(lvl,  plvl:  integer;  typ_pt:  out  integer); 

procedure  factor(lvl,  plvl:  integer;  typ_pt:  out  integer)  is 

tpt:  integer; 

begin 

case  syin  is 
when  intlitl  => 

typ_pt  :=  int _ pt; 

coderl(lit3,  secondsym); 
nextsytn; 

when  lparenthl  => 
nextsym; 

expression(lvl,  plvl,  typ_pt); 
checksym(rparenthl,  160); 

when  id  1  => 
vbl(lvl,  plvl,  tpt); 

if  (tpt  =  int_pt)  or  (tpt  =  bool_pt)  then 
coderO(Iod3); 
end  if; 

typ_pt  :=  tpt; 

when  notl  => 
nextsym; 

factor(lvl,  plvl,  tpt); 
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coderl(lit3,  0); 
end  if; 


nextsym; 

typ_pt  :=  bool_pt; 

when  others  =>  debug. error(162,symbols’pos(idl)); 
end  case; 
end; 


procedure  term_tail(lvl,  plvl,  typ_pt:  integer)  is 
tptl,  tpt2:  integer;  arith_op:  boolean;  sym2:  symbols; 
begin 


case  sym  is 

when  andl  |  start  |  modi  |  slashl  => 
sym2  :=  sym; 


nextsym; 

factor(lvl,  plvl,  tpt2); 
term_tail(lvl,  plvl,  typ_pt); 
case  sym2  is 

when  andl  =>  coder0(and3); 
when  starl  =>  coder0(mul3); 
when  modi  — >  coder0(mod3); 
when  slashl  =>  coder0(div.3); 
when  others  =>  null; 


end  case; 

when  colonl  |  semicolonl  |  rparenthl  |  commal  |  eql  |  nel  | 
ltl  |  lei  |  gtl  |  gel  |  plusopl  |  minusopl  j  orl  | 
thenl  |  loopl  =>  null; 


when  others  =>  debug.error(  165,  symbols’pos(andl)); 
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end  case; 
end; 

procedure  term(lvl,  plvl:  integer;  typ_pt:  out  integer)  is 

tpt:  integer; 

begin 

factor(lvl,  plvl,  tpt); 
term_tail(lvl,  plvl,  tpt); 
typ_pt  :=  tpt; 
end; 

procedure  sexp_tail(lvl,  plvl,  typ^pt:  integer)  is 

tptl,  tpt2:  integer;  sym2:  symbols; 

begin 

case  sym  is 

when  plusopl  |  minusopl  |  orl  => 
sym2  :=  sym; 
nextsym; 

term(lvl,  plvl,  tpt2); 
sexp_tail(lvl,  plvl,  tpt2); 
case  sym2  is 

when  plusopl  =>  coder0(add3); 
when  minusopl  =>  coder0(sub3); 
when  orl  =  >  coder0(or3); 
when  others  =>  null; 
end  case; 

when  colon  1  |  semicolon  1  |  rparenthl  |  commal  |  eql  |  nel  | 
ltl  |  lei  |  gtl  |  gel  |  thenl  |  loopl  =>  null; 
when  others  => 

debug. error(  168,  symbols’pos(orl)); 

end  case; 
end; 

procedure  simp_expr(lvl,  plvl:  integer;  typ_pt:  out  integer)  is 
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tptl,  tpt2:  integer;  aflag:  boolean;  sym2:  symbols; 
begin 


case  sym  is 

when  plusopl  |  minusopl  => 
aflag  :=  true; 
sym2  :=  sym; 
nextsym; 
when  others  => 
aflag  :=  false; 
end  case; 

term(lvl,  plvl,  tptl); 
if  aflag  and  (tptl  /=  int_pt)  then 
debug.error(169,  symbols’pos(plusopl)); 
end  if; 
if  aflag  then 

if  sym2  =  minusopl  then 
coder0(neg3); 
end  if; 
end  if; 

sexp_tail(lvl,  plvl,  tptl); 
typ_pt  :=  tptl; 
end; 

procedure  exp_tail(lvl,  plvl:  integer;  typ_pt:  in  out  integer)  is 

tpt:  integer;  bflag:  boolean;  sym2:  symbols; 

begin 

case  sym  is 

when  eql  j  nel  |  Itl  j  lei  |  gtl  |  gel  => 
sym2  :=  sym; 
nextsym; 

simp_expr(lvl,  plvl,  tpt); 
if  typ_pt  j—  tpt  then 
debug.error(171,symbols’pos(eql)); 
elsif  (tpt  j—  int_pt)  and  (tpt  /=  bool_pt)  then 
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debug.error(300,symbols’pos(eql)); 

else 

typ_pt  :=  bool_pt; 
end  if; 

case  sym2  is 

when  eql  =>  coder0(eq3); 
when  nel  =>  coder0(ne3); 
when  ltl  =>  coder0(lt3); 
when  lei  =>  coder0(le3); 
when  gtl  =>  coder0(gt3); 
when  gel  =>  coder0(ge3); 
when  others  =>  null; 
end  case; 

when  colonl  |  semicolonl  |  rparenthl  |  commal  |  thenl  |  loopl  => 
null; 

when  others  => 

debug.error(172,symbols’pos(eql)); 
end  case; 

end; 

procedure  expression(lvl,  plvl:  integer;  typ_pt:  out  integer)  is 

tptl,  tpt2:  integer; 

begin 

simp_expr(lvl,  plvl,  tptl); 
tpt2  :=  tptl; 
exp__tail(lvl,  plvl,  tpt2); 
typ_pt  :=  tpt2; 
end; 

procedure  vbl_tail(lvl,  pivl:integer;  typ_pt:  in  out  integer)  is 

tpt:  integer; 

begin 

case  sym  is 
when  Iparenthl  => 
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checksym(lparenthl,  120); 
expression(lvl,  plvl,  tpt); 
if  symbol_table(typ_pt).lo  /=  0  then 
coderl(lit3,  symbol_table(typ_pt).lo); 
coder0(sub3); 
end  if; 

checksym(rparenthl,  140); 
typ__pt  :=  symbol_table(typ_pt).typ__point; 
if  symbol_tabie(typ_pt).size  >  1  then 
coder l(lit3,  symbol_table(typ_pt).size); 
coder0(mu!3); 
end  if; 

coder0(add3); 
vbl_tail(lvl,  plvl,  typ_pt); 

when  colonl  |  semicolonl  |  rparenthl  |  commal  j  eql  |  nel  | 
ltl  |  lei  |  gtl  |  gel  |  plusopl  |  minusopl  |  andl  | 
starl  |  modi  |  slashl  |  orl  |  thenl  |  loopl  |  dotl  |  becomesl 
=>  null; 
when  others  => 

debug.error(122,  symbols’pos(idl)); 
end  case; 
end; 

procedure  vbll(lvl,  plvl,  pi:  integer;  typ_pt:  out  integer); 

procedure  vl_tail(lvl,  plvl,  pi,  plO:  integer;  typ_pt  :out  integer)  is 

pi  1 ,  pl2:  integer; 

begin 

case  sym  is 
when  dotl  => 

checksym(dotl,117); 
if  sym  /=  id  1  then 
debug.error(119,  symbols’pos(idl)); 
else 
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pil  :=  symbol_table(pl).typ_point; 
one_sect  _check(secondsy  m  ,pl  1  ,pl2); 
vbll(lvl,  plvl,  pl2,  typ_pt); 
end  if; 

when  colonl  |  semicolonl  j  rparenthl  |  commal  |  eql  |  nel  |  Itl  |  lei  | 
gtl  |  gel  |  plusopl  |  minusopl  |  andl  j  starl  |  modi  | 
slash  1  |  orl  j  thenl  |  loopl  |  becomes  1  =>  typ_pt  :=  plO; 

when  others  =>  debug.error(205,  symbols’pos^dl)); 
end  case; 
end; 

procedure  vbll(lvl,  plvl,  pi:  integer;  typ_pt:  out  integer)  is 

dummy,  tptl,  tpt2:  integer; 

begin 

if  symbol_table(pl).lvl  /=  -1  then 
if  symbol_table(pl).nrml  then 
coder2(lad3,symbol_table(pl).lvl,  symbol_table(pl).dsp); 
else 

coder2(lai3,symbol_table(pl).lvl,  symbol_table(pl).dsp); 
end  if; 
else 

coderl(lit3,  symbol_table(pl).dsp); 
coder0(add3); 
end  if; 

dummy  :=  0; 
nextsym; 

case  symbol_table(pl).typ  is 
when  rec3  => 

tptl  :=  symbol_table(p!).typ_point; 
vl_tail(lvl,  plvl,  pi,  tptl,  tpt2); 
typ_pt  :=  tpt2; 
when  int3  =  > 

vbl_tail(lvl,  plvl,  dummy); 
typ_pt  int _ pt; 
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when  bool3  => 


vbl_tail(lvl,  plvl,  dummy); 
typ_pt  :=  bool_pt; 
when  array3  => 

tptl  :=  symbol_table(pl).typ_point; 
vbl_tail(lvl,  plvl,  tptl); 
vl_tail(lvl,  plvl,  tptl,  tptl,  tpt2); 
typ_pt  :=  tpt2; 

when  others  =>  debug.error(141,symbols’pos(idl)); 
end  case; 
end; 


procedure  vbl2(lvl,  plvl,  pi:  integer;  typ_pt:  out  integer)  is 

pll:  integer; 

begin 

nextsym; 

checksym(dotl,  127); 
one_sect_check(secondsym,pl,pll); 
vbll(lvl,  plvl,  pll,  typ_pt); 
end; 


procedure  vbl(lvl,  plvl:  integer;  typ_pt:  out  integer)  is 

pi,  pll:  integer; 

begin 

pi  :=  id_index(secondsym,  lvl); 
case  symbol_table(pl).kind  is 
when  obj4  |  param4  =>  vbll(lvl,  plvl,  pi,  typ_pt); 
when  pkg_id4  => 
pll  :=  symbol_table(pl).pk_pt; 
vbl2(lvt,  plvl,  pll,  typ_pt); 

when  others  =>  debug.error(131,  symbols’pos(idl)); 
end  case; 
end; 
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procedure  exit_stat(lvl,  plvl:  integer;  cp:  in  out  integer)  is 

tpt:  integer; 

begin 

checksym(exit  1,103); 
checksym(whenl,104); 
expression(lvl,  plvl,  tpt); 
if  symbol  _table(tpt).typ  /=  boo!3  then 
debug.error(105,symbols’pos(booll)); 
end  if; 

coderl(jnz3,  cp); 
cp  :=  codept; 
end; 

procedure  p_sub_tail(lvl,  plvl,  pi,  plO:  integer); 

procedure  exp_p_sub(lvl,  plvl,  pi,  pH;  integer)  is 

tptl,  pl2,  sz:  integer; 

begin 

if  symbol_table(pll).trans  =  in5  then 
expression(lvl,  plvl,  tptl); 
sz  :=  symbol_table(tptl).size; 
if  sz  >  1  then 

coder2(blmi3,symbol_table(pll).dsp,  sz); 
else 

coder2(blmd3,  symbol_table(pll).dsp,  1); 
end  if; 

p_sub_tail(lvl,  plvl,  pi,  pll); 

elsif  symbol_table(pll).trans  =  out5  then  —redundant  check 
vbl(lvl,  plvl,  tptl); 

coder2(blmd3,symbol_table(pll),dsp,  1); 

p_sub_ta.il(lvl,  plvl,  pi,  PU); 
end  if; 
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procedure  p_sub_tail(lvl,  plvl,  pi,  plO:  integer)  is 

tptl,  pll,  p!2:  integer; 

begin 

case  sym  is 
when  cornmal  => 
nextsym; 
pll  :=  plO  +  1; 

exP_p_sub(lvl,  plvl,  pi,  pll); 
when  rparenthl  => 

if  plO  /=  symbol_tab!e(pl).param_end  then 
debug.error(198,  symbols’pos(idl)); 
end  if; 

when  others  =>  debug. error(197,  symbols’pos(id  1)); 
end  case; 
end; 

procedure  p_call_tail(lvl,  plvl,  pi:  integer)  is 

tptl,  pll,  pl2:  integer; 

begin 

case  sym  is 
when  lparenthl  => 
nextsym; 
pll  :=  pi  +  1; 
exp_p_sub(lvl,plvl,pi,pll); 
checksym(rparenthl,  182); 
when  semicolon  1  => 

if  pi  /=  symbol__tabie(pl).param_end  then 
debug. error(  188,  symbols’pos(idl)); 
end  if; 

when  others  =>  debug. error(187,  symbols’pos(idl)); 
end  case; 
end; 

procedure  proc_call_stat(lvl,  plvl,  pi:  integer)  is 
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addr,  pll,  pl2:  integer; 
begin 

—pi  points  to  symbol  table  entry  for  id 
-which  is  a  proc  id 
nextsym; 

—  p’epare  for  call-fix-up 

—  size  is  used  to  maintain  fix-up  information 

—  and  start  of  code  address 

coder l(mbl3,  symbol_table(pl).pdsp); 
p_cail_tail(lvl,  plvl,  pi); 
addr  :=  symbol_table(pl).size; 
if  symbol_table(pl).lo  =  -1  then 
if  symbol_table(pl).size  =  -1  then 
symbol_table(pl).size  :=  codept  +  1; 
else 

pll  :=  symbol_tabie(pl).size; 
while  pll  j—  -1  loop 
pl2  :=  pll; 

pll  :=  code(pll).opnd2; 
end  loop; 

code(pl2).opnd2  :=  codept  +  1; 
end  if; 

coder3(cal3,  symbol_tab!e(pl).lvl-f  1,  -1,-1); 
else 

coder3(cal3,  symbol_table(pl).lvl+l,  symbol_table(pI).size, 
symbol_table(pl).dsp); 

end  if; 
end; 

procedure  assign_stat(lvl,  plvl,  pi:  integer)  is 

typl,  t,yp2:  integer; 

begin 

vbll(lvi,  plvl,  pi,  typl); 
checksym(becomesl ,  97); 
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expression(lv!,  plvl,  typ2); 
if  symbol_table(typ2).size  =  1  then 
coder0(sto3); 
else 

coderl(bld3,  symbol_table(typ2).size); 
end  if; 
end; 

procedure  pk_stat_tail(lvl,  plvl,  pi:  integer)  is 

pi  1 :  integer; 

begin 

one_sect_check(secondsym,pl,pll); 
case  symbol_table(pll).kind  is 
when  proc_id4  =>  proc_call_stat(lvl.  plvl,  pll); 
when  obj4  |  param4  =>  assign_stat(lvl,  plvl,  pll); 

when  others  =>  debug. error(94,  symbols’pos(packl)); 
end  case; 

end; 


procedure  pk_stat(!vl,  plvl,  pi:  integer)  is 
begin 

nextsym; 

checksym(dotl,93), 
pk_stat_tail(lvl,  plvl,  pi); 
end; 

procedure  read_stat(lvl,  plvl:  integer)  is 

tpt:  integer; 

begin 

nextsym; 

checksym(!parenthl,  306); 
vblflvl,  plvl,  tpt); 
if  tpt  =  int_pt  then 
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coder0(rdi3); 
elsif  tpt  —  booI_pt  then 
coder0(rdb3); 
end  if; 

checksym(rparenthl,  320); 
end; 


procedure  w_tail(lvl,  pivl,  tp:  integer)  is 

tpt,  f:  integer; 

begin 

case  sym  is 

when  colonl  =>  nextsym; 
expression(lvl,  pivl,  tpt); 
if  tpt  f—  int_pt  then 
debug.error(305,  symbols’pos(idl)); 
end  if; 
f  :=  1; 

when  rparenthl  =>  f  :=  0; 

when  others  =>  debug. error(304,  symbols’pos(idl)); 
end  case; 

if  tp  =  int_pt  then 
coderl(wrti3,  f); 

elsif  tp  =  bool_pt  then 
coderl(wrtb3,  f); 

else  debug. error(3021, 200); 
end  if; 

end; 

procedure  write_body(lvl,  pivl:  integer)  is 

tpt:  integer; 

begin 

checksym(lparenthl,  301); 
expression(Ivl,  pivl,  tpt); 
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if  (tpt  /=  int_pt)  and  (tpt  /=  bool_pt)  then 
debug.error(302,  symbols’pos(idl)); 
end  if; 

w_tail(lvl,  plvl,  tpt); 
checksym(rparenth  1,303); 
end; 

procedure  write_stat(lvl,  plvl:  integer)  is 
begin 

case  sym  is 
when  writel  => 
nextsym; 

write_body(lvl,  plvl); 
when  writelnl  => 
nextsym; 

when  others  =>  null; 
end  case; 
end; 

procedure  simp_stat(M,  plvl:  integer)  is 

pi,  pi  1 ,  pl2:  integer; 

begin 

case  sym  is 
when  nulll  =  > 
checksym(n  j1U,901); 
coder0(nop3); 
when  idl  — > 

pi  :=  id_index(secondsym,lvl); 
case  symbol_table(pl).kind  is 
when  proc_id4  =>  proc__call_stat(lvl,  plvl,  pi); 
when  obj4  |  param4  =>  assign_stat(lvl,  plvl,  pi); 
when  pkg_id4  => 

pi  :=  symbol_table(pl).pk_pt;  --  make  sure  it  points  to 
--  pack  def 
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pk_stat(lvl,  plvl,  pi); 

when  others  =>  debug.error(91,symbols’pos(idl)); 
end  case; 

when  semicolonl  =>  null; 

when  writel  |  writelnl  =>  write_stat(lvl,  plvl); 
when  readl  =>  read_stat(lvl,  plvl); 
when  others  =>  debug.error(92,symbols’pos(idl)); 
end  case; 
end; 

procedure  stat_seq(lvl,  plvl:  integer); 

procedure  sing_elsif_part(lvl,  plvl:  integer;  cp:  in  out  integer)  is 

tpt,  cpl:  integer; 

begin 

checksym(elsifl,  331); 
expression(lvl,  plvl,  tpt); 
coderl(jz3,  -1); 
cpl  :=  codept; 
if  tpt  /=  bool_pt  then 
debug.error(  151  ,symbols’pos(elsifl )); 
end  if; 

checksym(thenl,152); 
stat_seq(lvl,  plvl); 
coderl(jmp3,cp); 
cp  :=  codept; 

code(cpl).opndl  :=  codept+1; 

end; 

procedure  elsif_part(lvl,  plvl:  integer;  cp:  in  out  integer)  is 
begin 

case  sym  is 
when  elsifl  =:> 
sing_elsif_part(lvl,  plvl,  cp); 
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elsif _ part(lvl ,  plvl,  cp); 

when  endl  |  eisel  =>  null; 
when  others  => 

debug.error(330,  symbols ’pos(elsifi)); 

end  case; 
end; 

procedure  else_part(lvl,  plvl:  integer)  is 
begin 

case  sym  is 
when  eisel  => 
nextsym; 

stat_seq(lvl,  plvl); 

when  endl  =>  null; 

when  others  =>  debug.error(154,  symbols’pos(elsel)); 
end  case; 
end; 

procedure  if_stat(lvl,  plvl:  integer)  is 
tpt,  cpl,  cp2,  cp3,  cp4  :  integer; 
begin 

checksym(ifl,145); 
expression(lvl,  plvl,  tpt); 
coderl(jz3,-l); 
cpl  :=  codept; 
if  tpt  /=  bool_pt  then 
debug.error(146,  symbols’pos(ifl)); 
end  if; 

checksym(thenl,  1451); 
stat_seq(Ivl,  plvl); 
coderl(jmp3,  -1); 
code(cpl).opndl  :  =  codept+1; 
cp2  :=codept; 
elsif_part(lvl,  plvl,  cp2); 


else _ pa.rt(l vl,  ptvl); 

cp3  :=  cp2; 
while  cp3  /=  -1  loop 
cp4  :=  cp3; 

cn3  :=  code(''p3).opndl; 
code(cp4).opndl  :=  codept+1; 
end  loop; 

checksym(end  1,147); 
checksym(ifl,148); 
end; 


procedure  lstat_seq(lvl,  plvl:  integer;  cp:  in  out  integer); 


procedure  loop_stat(lvl,  plvl,  cp,  cpw:  integer)  is 

cpO,  cpl,  cp2,  cp3,  cp4:  integer; 

begin 

checksym(loopl,133); 
if  cp  /=  -1  then 
cpO  :=  cp; 
else 

cpO  :=  -1; 
end  if; 

if  cpw  =  -1  then 
cp4  :=  codept  +  1; 
else 

cp4  :=  cpw; 
end  if; 

lstat_seq(lvl,  plvl,  cpO); 
coderl(jmp3,  cp4); 
cp3  :=  codept  -f  1; 
cpl  :=  cpO; 

—  fix  -  up  for  exit  statements  in  a  loop 
while  cpl  /=  -1  loop 
cp2  :=  cpl; 
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cpl  :=  code(cpl).opndl; 
code(cp2).opndl  :=  cp3; 
end  loop; 

checksym(endl,134); 

checksym(loopl,135); 

end; 

procedure  while_stat(lvl,  plvl:  integer)  is 

tpt,  cpl:  integer; 

begin 

checksym(whilel,137); 
cpl  :=  codept  -f  1; 
expression(lvl,  plvl,  tpt); 
if  tpt  /=  bool_pt  then 
debug.error(138,  symbols’pos(booll)); 
end  if; 

coderl(jz3,  -1); 

loop_stat(lvl,  plvl,  codept,  cpl); 
end; 

procedure  comp_stat(lvl,  plvl:  integer)  is 
begin 

case  syrn  is 

when  ifl  =>  if_stat(lvl,  plvl); 
when  loopl  =>  loop_stat(lvl,  plvl,  -1,  -1); 
when  while  1  =>  while_stat(lvl,  plvl); 
when  others  =>  debug. error(  106,  symbois’pos(idl)) 
end  case; 
end; 

procedure  statement(lvl,  plvl:  integer)  is 
begin 

case  sym  is 

when  idl  |  nulll  |  writel  |  writelnl  |  readl  => 
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simp_stat(lvl,  plvl);  checksemi(200); 

when  ifl  |  loopl  |  whilel  =>  comp_stat(lvl,  plvl);  checksemi(201); 
when  exitl  =>  debug.error(400,  symbols’pos(exitl)); 
when  others  =>  debug.error(90,  symbols’pos(ifl)); 
end  case; 
end; 


procedure  lstatement(lvl,  plvl:  integer;  cp:  in  out  integer)  is 

begin 

case  sym  is 

when  id  1  |  nulll  |  writel  |  writelnl  |  readl  | 
ifl  |  loopl  |  whilel  =>  statement(lvl,  plvi); 

when  exitl  =>  exit_stat(lvl,  plvl,  cp);  checksemi(401); 
when  others  =>  debug. error(402,  symbols’pos(ifl)); 
end  case; 
end; 

procedure  stat_seq_tail(lvl,  plvl:  integer)  is 
begin 

case  sym  is 

when  idl  |  nulll  |  ifl  |  loopl  |  whilel  | 
writel  j  writelnl  |  readl  => 
statement(lvl,  plvl); 
stat_seq_tail(lvl,  plvl); 
when  endl  |  elsifl  |  elsel  =>  null; 
when  exitl  =  >  debug.error(403,  symbols’pos(exitl)); 
when  others  => 

debug.error(85,  symbols’pos(idl)); 
end  case; 
end; 

procedure  lstat_seq_tail(lvl,  plvl:  integer;  cp:  in  out  integer)  is 
begin 

case  sym  is 
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when  id  1  j  nulll  j  ifl  |  exitl  |  loopl  |  whilel  | 
writel  J  writelnl  |  readl  => 
lstatement(lvl,  plvl,  cp); 
lstat_seq_taii(lvl,  pivl,  cp); 
when  endl  =>  null; 
when  others  => 

de  bug.error(4 11,  sy m  bols  ’pos(id  1 ) ) ; 
end  case; 
end; 

procedure  stat_seq(lvl,  plvl:  integer)  is 
begin 

statement(lvl,  plvl); 
stat_seq_tail(lvl,  plvl); 
end; 

procedure  lstat_seq(lvl,  plvl:  integer;  cp:  in  out  integer)  is 
begin 

lstatement(lvl,  plvl,  cp); 
lstat_seq_tail(lvl,  plvl,  cp); 
end; 

procedure  decl_part(lvl,  plvhinteger;  displ:  in  out  integer); 

procedure  subprog_part(lvl,  plvl,  displ,  tp:  integer)  is 

disp,  pt,  szl,  sz2:  integer; 

begin 

disp  :=  displ; 

:=  Pkg_d_pt  +  1; 

Pkg_<l_stack(pkg_d_pt)  0; 
decl_part(lvl,  plvl,  disp); 

^  pkg_d__stack(pkg__d_pt)  /=  0  then 
debug.error(112,  symbols’pos(packl)); 
else 
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Pkg_d_pt  :=  Pkg_d_Pt  -  l; 
end  if; 

checksym(  begin  1,50); 
symbol_table(tp).size  :=  codept  +  1; 
symbol_table(tp).lo  :=  1; 

szl  :=  0;  sz2  :=  0;  pt  :=  symbol_table(tp).sect_end; 
while  pt  >  tp  loop 
if  symboi_table(pt).kind  =  obj4  or 
symbol_table(pt).kind  =  param4  then 
szl  :=  szl  +  symbol_table(pt).size; 
end  if; 

if  symbol_table(pt).kind  =  param4  then 
sz2  :=  sz2  +  symbol_table(pt).size; 
end  if; 

pt  :=  symbol_tabie(pt).bkwrd; 
end  loop; 

symbol_table(tp).dsp  :=  szl  +  dispconst; 
symbol_table(tp).pdsp  :=  sz2  +  dispconst; 
stat_seq(lvl,  plvl); 
coderl(ret3,  lvl); 
checksym(endl,  51); 
end; 

procedure  subprog_decl(lvl,  plvl:  integer)  is 

tp,  disp:  integer; 

begin 

subprog_header(lvl,plvl,disp,tp); 
checksym(isl,  30); 

subprog_part{lvl  +  l,plvl+l,disp,tp); 
checksemi(31); 
end; 

procedure  pkg_d_decl(lvl,  plvl:  integer;  displ:  in  out  integer) 
dummy:  integer; 
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begin 


case  sym  is 

when  idl  =>  object_decl(lvl,  plvl,  displ);  pkg_d_decl(lvl,  plvl,  displ); 
when  typel  =>  type_decl(lvl,  plvl);  pkg_d_decl(lvl,  plvl,  displ); 
when  prod  =  >  subprog_header(lvl,  plvl,  displ, dummy);  checksemi(64); 
pkg_d_decl(lvl,  plvl,  displ); 
when  endl  =>  null; 

when  others  =>  debug.error(75,  symbols’pos(packl)); 
end  case; 
end; 

procedure  pkg_def_decl(lvl,  plvl:  integer;  displ:  in  out  integer)  is 
begin 

Pkg_d_stack(pkg_d_pt)  :=  pkg_d_stack(pkg_d_pt)  +  1; 
pkg_d_decl(lvl,  plvl,  displ); 
checksym(endl,61); 
checksym(packl,62); 
checksemi(63); 
end; 

procedure  pkg_b_decl(lvl,  plvhinteger;  displ:  in  out  integer)  is 
begin 

case  sym  is 

when  idl  =  >  object_decl(lvl,  plvl,  displ);  pkg_b_decl(lvl,  plvl,  displ); 
when  typel  =>  type_decl(lvl,  plvl);  pkg__b_decl(lvl,  plvl,  displ); 
when  prod  =>  subprog_decl(lvl,  plvl); 
pkg_b_decl(lvl,  plvl,  displ); 
when  endl  =>  null; 

when  others  =>  debug. error(74,  symbols’pos(packl )); 
end  case; 
end; 

procedure  pkg_body_decl(lvl,  plvl:  integer;  displ:  in  out  integer)  is 
begin 
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pkg_d_stack(pkg_d_pt)  :=  pkg_d_stack(pkg_d_pt)  -  1; 
pkg_b_decl(lv!,  plvl,  displ); 
checksym(endl,70); 
checksym(packl,71); 
checksemi(72); 
end; 

procedure  package_decl(lvl,  plvi:  integer;  displ:  in  out  integer); 

function  proc__check(psnl,  psn2:  integer)  return  boolean  is 
begin 

return  true; 
end; 

procedure  fix_p_addr(adr,  disp,  pt:  integer)  is 

cpt,  cpt2:  integer; 

begin 

cpt  :=  symbol_table(pt).size; 
if  symbol_table(pt).lo  =  -1  then 
symbol_table(pt).size  :=  adr; 
symboI_table(pt).dsp  :=  disp; 
symbol_table(pt).lo  :=  1; 
while  cpt  /—  -1  loop 
cpt2  :=  cpt; 
cpt  :=  code(cpt).opnd2; 
code(cpt2).opnd2  :=  adr; 
code(cpt2).opnd3  :=  disp; 
end  loop; 
end  if; 
end; 

procedure  pkg_search(pp,tp:  integer)  is 
ptl,  pt2,  pt3,  nm,  temp:  integer;  ok:  boolean; 
addr,  fix_addr:  integer; 
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begin 

-  pp  is  the  pointer  into  the  def 

—  to  is  the  pointer  into  the  body 

ptl  :=  symbol_table(pp).sect_end; 
pt2  ::=  symbol_table(tp).sect_end; 
temp  :=  symbol_table(tp).bkwrd; 
symboI_table(tp).bkwrd  :=  0; 
while  ptl  /=  pp  loop 

if  symbol_table(ptl).kind  =  proc_id4  then 
nm  :=  symbol_table(ptl).id_name; 
pt3  :=  pt2; 

symbol__table(0).id_name  :=  nm; 
while  symbol_table(pt3).id_name  /=  nm  loop 
pt3  :=  symboI_table(pt3).bkwrd; 
end  loop; 

fix_p_addr(symbol_table(pt3).size,symbol_tabie(pt3).dsp,ptl); 

end  if; 

ptl  :=  symbol_table(ptl).bkwrd; 
end  loop; 

symbol_table(tp).bkwrd  :=  temp; 
end; 


procedure  pkg_tail(lvl,  plvl:  integer;  displ:  in  out  integer)  is 

pU  j,  tp,  PP=  integer; 

begin 

case  sym  is 
when  idl  => 

check_new_id(2,  secondsym,  Ivl,  pi); 
if  pi  =  0  then 

enter_var(secondsym,  Ivl,  plvl,  pkg_id4); 
symbol_table(table_pt).typ  :=  pkg_def3; 
display(lvl-f-l)  :=  table_pt; 
symbol_table(tab!e_pt).sect_end  :=  table_pt; 
symbol_table(table_pt).pk_pt  :=  table_pt; 


page  149 


else  debug.error(53,symbols’pos(packl));  end  if; 
nextsym; 
checksym(isl,54); 
pkg_def_decl(lvl  +  l,  plvl,  displ); 
when  bodyl  => 
nextsym; 
if  sym  =  idl  then 

check_new_id(2,  secondsym,  lvl,  pi); 
if  pi  >  0  then 

if  symbol_table(pl).typ  /=  pkg_def3  then 
debug. error(59,  symbols’pos(packl )); 
else 

enter_var(secondsym,  lvl.  plvl,  pkg_id-l): 
tp  :=  table_pt; 

symbol_table(table_pt).typ  :=  pkg_bdy3; 
symbol_table(table_pt).pk_pt  pi; 
pp  :=  pl; 

display(lvl+l)  :=  table_pt; 

symbol_table(table_pt).sect_end  table_pt; 
end  if; 
else 

debug.error(60,symbols’pos(packl)); 
end  if; 
nextsym; 
else 

debug.error(61,  symbols’pos(id  1 )); 
end  if; 

checksym(isl,56); 
pkg_body_d  ;cl(lvl  +  l,  plvl,  displ); 
pkg_search(pp,  tp); 

--end  when  body! 

when  others  =>  debug. error(61,symbols'pos(pack  L)); 
end  case; 
end; 
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procedure  package_decl(lvl,  plvl:  integer;  displ:  in  out  integer)  is 
begin 

checksym(packl,  52); 
pkg_tail(ivl,  plvl,  displ); 
end; 

procedure  declaration(lvl,  plvkinteger;  disp:  in  out  integer)  is 
begin 

case  sym  is 

when  idl  =>  object_decl(lvl,  plvl,  disp); 
when  typel  =>  type_decl(lvl,  plvl); 
when  prod  =>  subprog_decl(lvl,  plvl); 
when  packl  =>  package_decl(lvl,  plvl,  disp); 
when  others  =>  debug.error(2,  symbols’pos(sym)); 
end  case; 
end; 

procedure  deci_part(lvl,  plvlhnteger;  displ:  in  out  integer)  is 

disp:  integer; 

begin 

disp  :=  displ; 

if  sym  =  typel  or  sym  =  idl  or  sym  =  prod  or  sym  =  packl  then 
declaration(lvl,  plvl,  disp); 
decl_part(lvl,  plvl,  disp); 
elsif  sym  /=  beginl  then 
debug.error(52,  symbols’pos(procl)); 
end  if; 

displ  :=  disp; 
end; 

procedure  program  is 
begin 

subprog_decl(-l,  -1); 
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end; 


procedure  emit_code(n:  integer)  is 
use  int_io; 

sz,  szO,  szl,  sz2,  sz3,  opval:  integer; 
op:  operation; 
begin 
sz  :=  0; 

for  i  in  1  ..  n  loop 
opval  :=  code(i).oprtn; 
op  :=  operation’val(opval); 
szO  :=  debug. size(opval); 
put(codefi, opval  ,sz0); 
text_io.put(codefi,’  ’); 
sz  :=  sz  +  szO  +  1; 
if  sz  >=  64  then 
text_io.new_line(codefi); 
sz  :=  0; 
end  if; 

if  op_sing(op)  then 
szl  :=  debug.size(code(i).opndl); 
put(codefi,  code(i).opndl,szl); 
text_io.put(codefi,’  ’); 
sz  :=  sz  +  szl  -f  1; 
if  sz  >=  64  then 
text  _io.  new  _line(codefi); 
sz  :=  0; 
end  if; 

elsif  op_doub(op)  then 
szl  :=  debug. size(code(i).opndl); 
sz2  debug. size(code(i).opnd2); 
put(codefi,  code(i).opndl,szl); 
text_jo.put(codefi,’  ’); 
put(codefi,  code(i).opnd2,sz2); 
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text_i°.put(codefi,>  ’); 
sz  :=  sz  +  szl  +  sz‘2  +  2; 
if  sz  >=  64  then 
text_io.nevv_line(codefi); 
sz  :=  0; 
end  if; 

elsif  op_trip(op)  then 
szl  :=  debug. size(code(i).opndl); 
sz2  :=  debug. size(code(i).opnd2); 
sz3  :  =  debug. size(code(i).opnd3); 
put(codefi,  code(i).opndl,szl); 
text_io.put(codefi,’  ’); 
put(codefi,  code(i).opnd2,sz2); 
text_io.put(codefi,’  ’); 
put(codefi,  code(i).opnd3,sz3); 
text_io.put(codefi,’  ’); 
sz  :=  sz  -f  szl  +  sz2  +  sz3  +  3; 
if  sz  >=  64  then 
text  _io.  new  _line(codefi); 
sz  :=  0; 
end  if; 
end  if; 
end  loop; 

t  ext  _  io.  close(  codefi ) ; 
end; 

begin 
getfile; 
nextsym; 
coderl(mbl3,0); 
coder3(cal3,0,- 1,-1); 
coder0(hlt3); 
program; 

code(2).opndl  :=  symbol_table(5).lvl-f  1; 


page  153 


code(2).opnd2  :=  symbol_table(5).size; 
code(2).opnd3  :=  symboI_table(5).dsp; 
coder0(endm3); 

—  show_ops; 

—  show_table2; 
emit_code(codept); 
exception 

when  text_io.name_error  => 
text_io.put_line(”File  ‘outl’  not  found”); 
when  err_excep  =  > 
text  _io.put_line(”  Error”), 
when  coderr  => 

text_io.put_line(”Too  much  code”); 
end  pass3; 
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Pass4:  The  a-machine. 


The  a-machine  is  a  stack  machine  patterned  after  the  Pascal  p-machine.  This 
machine  interprets  the  code  produced  by  pass3.  This  kind  of  machine  was  used  in  an  early 
version  of  Pascal.  It  can  be  found  in  [W]  and  also  in  [EJ.  It  presents  an  excellent  alternative  to 
producing  machine  code  or  assembly  code  because  it  is  written  in  a  high  level  language  and  is 
more  easily  understood.  Eventually,  for  use  in  a  working  compiler  it  can  be  translated  into 
machine  code  and  optionally  an  optimization  pass  can  be  placed  prior  to  it.  We  list  the  a- 
machine  here. 

with  text_io; 

package  int_io  is  new  text_io.integer_io(integer); 
with  text_io;  with  int_io; 

procedure  pass4  is 

—  operations 

type  operation  is  (add3,  and3,  bld3,  blmd3,  blmi3,  cal3,  div3,  -6 
endm3,  eq3,  --8 

ge3,  gt3,  hlt3,  jmp3,  jnz3,  jz3,  lad3,-15 
lai3,  le3,  lit3,  lod3,  lt3,  mbl3,  mod3,-23 
mul3,  ne3,  neg3,  nop3,  not3,  or3,  rdb3,  rdi3,  —31 
ret3,  sto3,  sub3,  wrtb3,  wrti3);  —36 

—  end  operations 

op_sing,  op_doub,  op_trip:  array(operation)  of  boolean  := 

(add3  ..  wrti3  =>  false); 
type  order  is  record 
oprtn:  operation; 
opndl,  opnd2,  opnd3:  integer; 
end  record; 

codelim:  constant:=  500; 

code:  array(l  ..  codelim)  of  order; 

codefi,  outx:  text_io.file_type; 

display:  array(integer  range  -  I  ..  50)  of  integer; 
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stack:  array(integer  range  1  ..  500)  of  integer; 
stkpt  :  integer; 
ip:  integer;  stop:  boolean; 
subtype  str7  is  string(l  ..  7); 
type  oprek  is  record 
opnm:str7; 
oplen:integer; 
end  record; 

opmnem:  array(operation)  of  oprek; 
last_code:  integer; 

procedure  init  is 

code_index:  integer;  op:  operation;  f_op,  opd:  integer; 

use  text_io; 

begin 

open(codefi,in_file,  ’’code”); 
create(outx,  out_file,  ”outp”); 
op_sing(lit3)  :=  true; 
op_sing(mbl3)  true; 
op_sing(jmp3)  :=  true; 
op_sing(jnz3)  :=  true; 
op_sing(jz3)  :=  true; 
op_sing(wrti3)  :=  true; 
op_sing(wrtb3)  :=  true; 
op_trip(cal3)  :=  true; 
op_doub(lad3)  :=  true; 
op_doub(lai3)  :=  true; 
op_sing(bld3)  :=  true; 

°p_doub(blmd3)  :=  true; 
op_doub(blmi3)  :=  true; 
op_sing(ret3)  :=  true; 
opmnem  :=  ((”add3  ”,  4), 

(”and3  ”,  4), 

(”bld3  ”,  4), 
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(”blmd3  ”,  5), 

(”blmi3 

”,5), 

(”cal3 

”,4), 

(”div3 

”,  4), 

(”endm3  ”,  5), 

(”eq3 

”,  3), 

(”ge3 

”,  3), 

(’  gt3 

”,  3), 

(”hlt3 

”,  4), 

(”jmp3 

”,  4), 

(”jnz3 

”,  4), 

(”jz3 

”,  3), 

(”lad3 

”,  4), 

(”lai3 

”,  4), 

(”le3 

”,  3), 

(”lit3 

”,  4), 

(”lod3 

”,  4), 

(”lt3 

”,  3), 

(”mb!3 

”,  4), 

(”mod3 

”,  5), 

(”mul3 

”,  4), 

(”ne3 

”,  3), 

(”neg3 

”,  4), 

(”nop3 

”,  4), 

(”not3 

”,  4), 

(”oi'3 

”,  3), 

(”rdb3 

”,  4), 

(”rdi3 

”,  4), 

(” ret 3 

”,  4), 

(”sto3 

”,  4), 

(”sub3 

”,  4), 

(”wrtb3 

”,  5), 

(”wrti3 

”,  5)); 

code_inde> 

::=  0; 
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loop 

int_io.get(codefi,  f_op); 
op  :=  operation’val(f_op); 
code_ index  :=  code_ index  +  1; 
code(code_index).oprtn  :=  op; 
if  op_sing(op)  then 

int  _io.get(codefi,  code(code_index) .opnd  1 ); 
elsif  op_doub(op)  then 

int_io.get(codefi,  code(code_index).opndl); 
int_io.get(codefi,  code(code_index).opnd2); 
elsif  op__trip(op)  then 

int_io.get(codefi,  code(code_index).opndl); 
int_io.get(codefi,  code(code_index).opnd2); 
int_io.get(codefi,  code(code_index).opnd3); 
end  if; 

exit  when  op  =  endm3; 
end  loop; 

last_code  :=  code_index; 
stop  :=  false; 
end; 

procedure  execute  is 
op:  operation; 

opdl,  opd2,  opd3,  hold,  base:  integer; 
tl,  t2,  num:  integer; 
procedure  show_stack  is 
begin 

text_io.put(”stkpt  =”  );int_io.put(stkpt);text_io.new_line; 
text_io.put(”base  =”);int_io.put(base);text_io.new_line; 
for  i  in  1  ..  stkpt  loop 

int_io.put(i,4);  text_io.put(”;  ”);  int_io.put(stack(i)); 
text_io.new_line; 
end  loop; 
end; 
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begin 

—  base  points  to  the  beginning  of  an  activation  record 

—  base  +  1  is  the  dynamic  pointer 

—  base  +  2  is  the  static  pointer 

—  static  pointers  are  maintained  by  means  of  a  display 
ip  :=  1; 

base  :=  -1; 
stkpt  :=  1; 
display(O)  :=  -1; 
loop 

op  :=  code(ip).oprtn; 
if  op_sing(op)  then 
opdl  :=  code(ip).opndl; 
elsif  op_doub(op)  then 
opdl  :=  code(ip).opndl; 
opd2  :=  code(ip).opnd2; 
elsif  op_trip(op)  then 
opdl  :=  code(ip).opndl: 
opd2  :=  code(ip).opnd2; 
opd3  :=  code(ip).opnd3; 
end  if; 

ip  :=  ip  +  1; 
case  op  is 
when  add3  => 
stkpt  :=  stkpt  -  1; 

stack(stkpt)  :=  stack(stkpt)  +  stack(stkpt  +  1); 
when  and3  => 
stkpt  :=  stkpt  -  1; 
if  stack(stkpt)  /—  0  then 
stack(stkpt)  :=  stack(stkpt  -f-  1); 
end  if; 

when  bld3  =  > 
t2  :=  stack(stkpt); 
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tl  :=  stack(stkpt  -  1); 
for  i  in  0  ..  opdl  -  1  loop 
stack(tl  -f  i)  :=  stack(t2  +  i); 
end  loop; 

stkpt  :=  stkpt  -  2; 
when  blmi3  => 
tl  :=  stack(stkpt); 
t2  :=  base  +  opdl; 
for  i  in  0  ..  opd2  -  1  loop 
stack(t2  -f  i)  :=  stack(tl  -f  i); 
end  loop; 

stkpt  :=  stkpt  -  1; 
when  blmd3  => 

stack(base  +  opdl)  :=  stack(stkpt); 
stkpt  :=  stkpt  -  1; 
when  cal3  => 
stkpt  :=  base  +  opd3  -  1; 
stack(base):=  ip; 
stack(basc+2)  :  —  display(opdl); 
display(opdl)  :=  base; 
ip  opd2; 
when  div3  => 
stkpt  :=  stkpt  -  1; 

stack(stkpt)  :=  stack(stkpt)  /  stack(stkpt  +  1); 
when  eq3  => 
stkpt  :=  stkpt  -  1; 

stack(stkpt)  :=  boolean’pos(stack(stkpt)  =  stack(stkpt+l)); 
when  ge3  => 
stkpt  :=  stkpt  -  1; 

stack(stkpt)  :=  boolean’pos(stack(stkpt)  >=  stack(stkpt  +  l)); 
when  gt3  => 
stkpt  :=  stkpt  -  1; 

stack(stkpt)  :=  boolean ’pos(stack(stkpt)  >  stack(stkpt+l)); 
when  hlt3  =  >  stop  :=  true; 
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when  jmp3  =>  ip  :=  opdl; 
when  jnz3  => 
if  stack(stkpt)  /=  0  then 
ip  :=  opdl; 
end  if; 

stkpt  :=  stkpt  -  1; 
when  jz3  => 
if  stack(stkpt)  =  0  then 
ip  :=  opdl; 
end  if; 

stkpt  :=  stkpt  -  1; 
when  lad3  => 
stkpt  :=  stkpt  +  1; 
stack(stkpt)  :=  display(opdl)  -f  opd2; 
when  le3  — > 
stkpt  :=  stkpt  -  1; 

stack(stkpt)  :=  boolean’pos(stack(stkpt)  <=  stack(stkpt+l)); 
when  Ht3  => 
stkpt  :=  stkpt  +  1; 
stack(stkpt)  :=  opdl; 
when  lai3  => 
stkpt  stkpt  +  1; 

stack(stkpt)  :•=  stack(display(opdl)  +  opd2); 
when  lod3  => 

stack(stkpt)  :=  stack(stack(stkpt)); 
when  lt3  => 
stkpt  :=  stkpt  -  1; 

stack(stkpt)  :=  boolean’pos(stack(stkpt)  <  stack(stkpt  +  l)); 
when  mbl3  => 
stack(stkpt-|-2)  :=  base; 
base  :=  stkpt  +  1; 
stkpt  :=  base  +  opdl; 
when  mod 3  => 
stkpt  :=  stkpt  -  1; 


page  161 


stack(stkpt)  :=  stack(stkpt)  mod  stack(stkpt  +  1); 
when  mu!3  => 
stkpt  :=  stkpt  -  1; 

stack(stkpt)  :=  stack(stkpt)  *  stack(stkpt  +  1); 
when  ne3  —  > 
stkpt  :=  stkpt  -  1; 

stack(stkpt)  :=  boolean’pos(stack(stkpt)  /=  stack(stkpt+l)); 
when  neg3  =>  stack(stkpt)  :=  -  stack(stkpt); 
when  not3  =>  stack(stkpt)  :=  1  -  stack(stkpt); 
when  or3  => 
stkpt  stkpt  -  1; 
if  stack(stkpt)  =  0  then 
stack(stkpt)  :=  stack(stkpt  -f  1); 
end  if; 

when  rdb3  — > 
int_io.get(hold); 

if  (hold  /=  0)  and  (hold  /=  1)  then 
text_io.put_line(outx,  ’’Boolean  read  error  ”); 
stop  :=  true; 
else 

stkpt  :=  stkpt  +  1; 
stack(stkpt)  :=  hold; 
end  if; 

when  rdi3  => 
text_io.put(”?”); 
stkpt  :=  stkpt  +  1; 
int_io.get(stack(stkpt)); 
when  ret3  => 

display(opdl)  :=  stack(base  +  2); 
ip  :=  stack(base); 
stkpt  :=  base  -  1; 
base  :=  stack(base  +  1); 
when  sto3  => 

stack(stack(stkpt  -  1))  :=  stack(stkpt); 
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stkpt  :=  stkpt  -  2; 
when  sub3  => 
stkpt  :=  stkpt  -  1; 

stack(stkpt)  ;=  stack(stkpt)  -  stack(stkpt  +  1); 
when  wrtb3  => 
if  stack(stkpt)  =  0  then 
text  _io.  put  _line(outx,”false”); 

elsif  stack(stkpt)  =  1  then 
text_io.put_Jine(outx,  ’’true”); 
end  if; 

stkpt  :=  stkpt  -  1; 
when  wrt:3  => 
tl  :=  stack(stkpt); 
stkpt  :=  stkpt  -  1; 
if  tl  >  0  then 

int_io.put(outx,  stack(stkpt),  tl); 
else 

int_io.put(outx,  stack(stkpt),  10); 
end  if; 

text_io.new_line(outx); 
stkpt  stkpt  -  1; 
when  others  =>  null; 
end  caae; 
exit  when  stop; 
end  loop; 


procedure  show_ops  is 

op:  operation; 

begin 

for  i  in  1  ..  last_code  loop 
int_io.put(i,4);text_io.put(”:  ”); 
op  :=  code(i).oprtn; 
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text_io.put(opmnem(op).opnm); 
if  op_sing(op)  then 
int_io.put(code(i).opndl,6); 
elsif  op_doub(op)  then 
int_io.put(code(i).opndl,6); 
int_io.put(code(i).opnd2,6); 
elsif  op__trip(op)  then 
int_io.put(code(i).opnd  1,6); 
int_io.put(code(i).opnd2.6); 
int_io.put(code(i).opnd3,6); 
end  if; 

text  _io.  new  _  line; 
end  loop; 

text_io.put(”!?.st  code  —  ”); 
int__io.put(last_code); 
text_io.new__!ine; 
end; 

begin 

init; 

—  show_ops; 
execute; 

text_io.close(outx); 
end  pass4; 
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Conclusion: 


VVe  believe  that  the  course  we  produced  was  quite  successful.  Ada  supported  the 
design  and  programming  features  of  our  exr.mple  compiler  quite  well.  If  Ada  can  be  faulted  it 
probably  lies  with  the  somewhat  large  storage  overhead  in  both  files  and  memory.  On  the 
other  hand  we  found  that  the  Ada  syntax  and  the  strong  typing  supported  good  program 
design.  VVe  believe  these  features  o  Ada  caught  many  problems  before  they  became  large 
problems.  The  programming  proceeded  with  a  minimum  of  difficulty.  The  experience  has 
shown  that  Ada  can  be  used  with  great  utility  for  a  compiler  design  course.  The  writer  plans 
to  continue  to  use  Ada  in  this  course  in  the  future. 

The  course  compiler  in  machine  readable  form  is  available  in  a  disk  attached  to  the 
cover  of  the  report.  Please  read  the  file  called  READ. ME  first. 
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